unit Pipes;
////////////////////////////////////////////////////////////////////////////////
//
//   Unit        :  Pipes
//   Author      :  rllibby
//   Date        :  01.30.2003  -  Original code
//
//                  01.19.2006  -  Code overhauled to allow for usage in dll's
//                                 when compiled with Delphi 6 and up.
//
//                  04.03.2008  -  Second overhaul after finding that memory leaks
//                                 in the server thread handling when run under
//                                 load. Also found cases where messages were missed
//                                 using PeekMessage due to the queue being full. It
//                                 seems that the message queue has a 10000 message
//                                 limit.
//
//                  04.04.2008  -  (1) Better memory handling for messages.
//                                 (2) Smart reallocation for overlapped reads
//                                 (3) Message chunking is handled, which alleviates
//                                 the developer from manually splitting data writes
//                                 over the network when the data is > 65K.
//                                 (4) Temp file backed streams for multi packet
//                                 messages.
//                                 (5) Added the ability to throttle down client
//                                 based on memory consumption in the write queue.
//
//                  05.30.2008  -  Updated the client / server components to allow
//                                 the Active (server) and Disconnect (client) calls
//                                 to be made while processing an event from the
//                                 component.
//
//                  06.05.2008  -  Wrapped up the TPipeConsole component, which
//                                 handles redirection from console processes.
//                                 Also provides a means of synchronous execution
//                                 by way of the Execute(...) function.
//
//                  10.20.2008  -  Added remote code threading for obtaining the
//                                 console handle directly. If this fails, the
//                                 code will revert to enumerating the windows
//                                 of the console process. Also added priority
//                                 setting for the process.
//
//   Description :  Set of client and server named pipe components for Delphi, as
//                  well a console pipe redirection component.
//
//   Notes:
//
//      TPipeClient
//
//      -  The worker thread coordinates events with the component by way of
//         SendMessage. This means the thread that the component lives on has
//         to have a message loop. Also, it means that the developer needs
//         to watch what is done in the TPipeClient events. Do not expect the
//         following calls to work from within the events:
//
//         -  FlushPipeBuffers
//         -  WaitForReply
//         -  Write (works, but no memory throttling)
//
//         The reason these calls do not work is that they are expecting
//         interaction from the worker thead, which is currently stalled while
//         waiting on the event handler to finish (and the SendMessage call to
//         complete). I have coded these routines so that they will NOT deadlock,
//         but again, don't expect them to ever return success if called from
//         within one of TPipeClient events. The one exception to this is the
//         call to Disconnect, which can be called from within an event. If
//         called from within an event, the component will PostMessage to itself
//         and will perform the true disconnect when the message is handled.
//
//      TPipeServer
//
//      -  The worker threads coordinate events with the component by way of
//         SendMessage. This means the thread that the component lives on has
//         to have a message loop. No special restrictions for what is done in
//         the event handlers.
//
//      TPipeConsole
//
//      -  The worker thread coordinates events with the component by way of
//         SendMessage. This means the thread that the component lives on has
//         to have a message loop. No special restrictions for what is done in
//         the event handlers.
//
////////////////////////////////////////////////////////////////////////////////
interface

////////////////////////////////////////////////////////////////////////////////
//   Include units
////////////////////////////////////////////////////////////////////////////////
uses
  Windows, SysUtils, Classes, Messages;

////////////////////////////////////////////////////////////////////////////////
//   Compiler defines
////////////////////////////////////////////////////////////////////////////////

  {$IFDEF VER140} { Borland Delphi 6.0 }
     {$DEFINE DELPHI_6_ABOVE}
  {$ENDIF}

  {$IFDEF VER150} { Borland Delphi 7.0 }
     {$DEFINE DELPHI_6_ABOVE}
  {$ENDIF}

  {$IFDEF VER160} { Borland Delphi 8.0 }
     {$DEFINE DELPHI_6_ABOVE}
  {$ENDIF}

  {$IFDEF VER170} { Borland Delphi 2005 }
     {$DEFINE DELPHI_6_ABOVE}
  {$ENDIF}

  {$IFDEF VER180} { Borland Delphi 2007 }
     {$DEFINE DELPHI_6_ABOVE}
  {$ENDIF}

  {$IFDEF VER185} { Borland Delphi 2007 }
     {$DEFINE DELPHI_6_ABOVE}
  {$ENDIF}

  {$IFDEF VER190} { Borland Delphi 2009 }
     {$DEFINE DELPHI_6_ABOVE}
  {$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//   Resource strings
////////////////////////////////////////////////////////////////////////////////
resourcestring
  resThreadCtx      =  'The notify window and the component window do not exist in the same thread!';
  resPipeActive     =  'Cannot change property while server is active!';
  resPipeConnected  =  'Cannot change property when client is connected!';
  resBadPipeName    =  'Invalid pipe name specified!';
  resPipeBaseName   =  '\\.\pipe\';
  resPipeBaseFmtName=  '\\%s\pipe\';
  resPipeName       =  'PipeServer';
  resConClass       =  'ConsoleWindowClass';
  resComSpec        =  'ComSpec';

////////////////////////////////////////////////////////////////////////////////
//   Min, max and default constants
////////////////////////////////////////////////////////////////////////////////
const
  MAX_NAME          =  256;
  MAX_WAIT          =  1000;
  MAX_BUFFER        =  Pred(MaxWord);
  DEF_SLEEP         =  100;
  DEF_MEMTHROTTLE   =  10240000;

////////////////////////////////////////////////////////////////////////////////
//   Pipe mode constants
////////////////////////////////////////////////////////////////////////////////
const
  PIPE_MODE         =  PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT;
  PIPE_OPENMODE     =  PIPE_ACCESS_DUPLEX or FILE_FLAG_OVERLAPPED;
  PIPE_INSTANCES    =  PIPE_UNLIMITED_INSTANCES;

////////////////////////////////////////////////////////////////////////////////
//   Pipe handle constants
////////////////////////////////////////////////////////////////////////////////
const
  STD_PIPE_INPUT    =  0;
  STD_PIPE_OUTPUT   =  1;
  STD_PIPE_ERROR    =  2;

////////////////////////////////////////////////////////////////////////////////
//   Mutliblock message constants
////////////////////////////////////////////////////////////////////////////////
const
  MB_MAGIC          =  $4347414D;  // MAGC
  MB_START          =  $424D5453;  // STMB
  MB_END            =  $424D5445;  // ETMB
  MB_PREFIX         =  'PMM';

////////////////////////////////////////////////////////////////////////////////
//   Object instance constants
////////////////////////////////////////////////////////////////////////////////
const
  INSTANCE_COUNT    =  313;

////////////////////////////////////////////////////////////////////////////////
//   Pipe window message constants
////////////////////////////////////////////////////////////////////////////////
const
  WM_PIPEERROR_L    =  WM_USER + 100;
  WM_PIPEERROR_W    =  WM_USER + 101;
  WM_PIPECONNECT    =  WM_USER + 102;
  WM_PIPESEND       =  WM_USER + 103;
  WM_PIPEMESSAGE    =  WM_USER + 104;
  WM_PIPE_CON_OUT   =  WM_USER + 105;
  WM_PIPE_CON_ERR   =  WM_USER + 106;
  WM_PIPEMINMSG     =  WM_PIPEERROR_L;
  WM_PIPEMAXMSG     =  WM_PIPE_CON_ERR;

////////////////////////////////////////////////////////////////////////////////
//   Posted (deferred) window messages
////////////////////////////////////////////////////////////////////////////////
const
  WM_THREADCTX      =  WM_USER + 200;
  WM_DOSHUTDOWN     =  WM_USER + 300;

////////////////////////////////////////////////////////////////////////////////
//   Thread window message constants
////////////////////////////////////////////////////////////////////////////////
const
  CM_EXECPROC       =  $8FFD;
  CM_DESTROYWINDOW  =  $8FFC;

////////////////////////////////////////////////////////////////////////////////
//   Pipe exception type
////////////////////////////////////////////////////////////////////////////////
type
  EPipeException    =  class(Exception);

////////////////////////////////////////////////////////////////////////////////
//   Pipe data type
////////////////////////////////////////////////////////////////////////////////
type
  HPIPE             =  THandle;

////////////////////////////////////////////////////////////////////////////////
//   Record and class types
////////////////////////////////////////////////////////////////////////////////
type

  // Forward declarations
  TPipeServer       =  class;
  TPipeClient       =  class;
  TWriteQueue       =  class;

  // Std handles for console redirection
  TPipeStdHandles   =  Array [STD_PIPE_INPUT..STD_PIPE_ERROR] of THandle;

  // Process window info
  PPipeConsoleInfo  =  ^TPipeConsoleInfo;
  TPipeConsoleInfo  =  packed record
     ProcessID:     DWORD;
     ThreadID:      DWORD;
     Window:        HWND;
  end;

  // Data write record
  PPipeWrite        =  ^TPipeWrite;
  TPipeWrite        =  packed record
     Buffer:        PChar;
     Count:         Integer;
  end;

  // Data write message block
  PPipeMsgBlock     =  ^TPipeMsgBlock;
  TPipeMsgBlock     =  packed record
     Size:          DWORD;
     MagicStart:    DWORD;
     ControlCode:   DWORD;
     MagicEnd:      DWORD;
  end;

  // Data writer list record
  PWriteNode        =  ^TWriteNode;
  TWriteNode        =  packed record
     PipeWrite:     PPipeWrite;
     NextNode:      PWriteNode;
  end;

  // Server pipe info record
  PPipeInfo         =  ^TPipeInfo;
  TPipeInfo         =  packed record
     Pipe:          HPIPE;
     KillEvent:     THandle;
     WriteQueue:    TWriteQueue;
  end;

  // Thread sync info
  TSyncInfo         = class
     FSyncBaseTID:  THandle;
     FThreadWindow: HWND;
     FThreadCount:  Integer;
  end;

  // Exception frame
  PRaiseFrame       =  ^TRaiseFrame;
  TRaiseFrame       =  record
    NextRaise:      PRaiseFrame;
    ExceptAddr:     Pointer;
    ExceptObject:   TObject;
    ExceptionRecord:PExceptionRecord;
  end;

  // Window proc
  TWndMethod        =  procedure(var Message: TMessage) of object;

  // Object instance structure
  PObjectInstance   =  ^TObjectInstance;
  TObjectInstance   =  packed record
     Code:          Byte;
     Offset:        Integer;
     case Integer of
        0  :  (Next:   PObjectInstance);
        1  :  (Method: TWndMethod);
  end;

  // Object instance page block
  PInstanceBlock    =  ^TInstanceBlock;
  TInstanceBlock    =  packed record
     Next:          PInstanceBlock;
     Counter:       Word;
     Code:          Array [1..2] of Byte;
     WndProcPtr:    Pointer;
     Instances:     Array [0..INSTANCE_COUNT] of TObjectInstance;
  end;

  // Pipe context for error messages
  TPipeContext      =  (pcListener, pcWorker);

  // Pipe Events
  TOnConsole        =  procedure(Sender: TObject; Stream: TStream) of object;
  TOnConsoleStop    =  procedure(Sender: TObject; ExitValue: LongWord) of object;
  TOnPipeConnect    =  procedure(Sender: TObject; Pipe: HPIPE) of object;
  TOnPipeDisconnect =  procedure(Sender: TObject; Pipe: HPIPE) of object;
  TOnPipeMessage    =  procedure(Sender: TObject; Pipe: HPIPE; Stream: TStream) of object;
  TOnPipeSent       =  procedure(Sender: TObject; Pipe: HPIPE; Size: DWORD) of object;
  TOnPipeError      =  procedure(Sender: TObject; Pipe: HPIPE; PipeContext: TPipeContext; ErrorCode: Integer) of object;

  // TWriteQueue class
  TWriteQueue       =  class(TObject)
  private
     // Private declarations
     FMutex:        THandle;
     FDataEv:       THandle;
     FEmptyEv:      THandle;
     FDataSize:     LongWord;
     FHead:         PWriteNode;
     FTail:         PWriteNode;
     procedure      UpdateState;
     function       NodeSize(Node: PWriteNode): LongWord;
  protected
     // Protected declarations
     procedure      Clear;
     procedure      EnqueueControlPacket(ControlCode: DWORD);
     procedure      EnqueueMultiPacket(PipeWrite: PPipeWrite);
     function       GetEmpty: Boolean;
     function       NewNode(PipeWrite: PPipeWrite): PWriteNode;
  public
     // Public declarations
     constructor    Create;
     destructor     Destroy; override;
     procedure      Enqueue(PipeWrite: PPipeWrite);
     procedure      EnqueueEndPacket;
     procedure      EnqueueStartPacket;
     function       Dequeue: PPipeWrite;
     property       DataEvent: THandle read FDataEv;
     property       DataSize: LongWord read FDataSize;
     property       Empty: Boolean read GetEmpty;
     property       EmptyEvent: THandle read FEmptyEv;
  end;

  // TThreadSync class
  TThreadSync       =  class
  private
     // Private declarations
     FSyncRaise:    TObject;
     FMethod:       TThreadMethod;
     FSyncBaseTID:  THandle;
  public
     // Public declarations
     constructor    Create;
     destructor     Destroy; override;
     procedure      Synchronize(Method: TThreadMethod);
     property       SyncBaseTID: THandle read FSyncBaseTID;
  end;

  // TThreadEx class
  TThreadEx         =  class(TThread)
  private
     // Private declarations
     FSync:         TThreadSync;
     procedure      HandleTerminate;
  protected
     // Protected declarations
     procedure      SafeSynchronize(Method: TThreadMethod);
     procedure      Synchronize(Method: TThreadMethod);
     procedure      DoTerminate; override;
  public
     // Public declarations
     constructor    Create(CreateSuspended: Boolean);
     destructor     Destroy; override;
     procedure      Wait;
     property       Sync: TThreadSync read FSync;
  end;

  // TSyncManager class
  TSyncManager      =  class(TObject)
  private
     // Private declarations
     FThreadLock:   TRTLCriticalSection;
     FList:         TList;
  protected
     // Protected declarations
     procedure      DoDestroyWindow(Info: TSyncInfo);
     procedure      FreeSyncInfo(Info: TSyncInfo);
     function       AllocateWindow: HWND;
     function       FindSyncInfo(SyncBaseTID: LongWord): TSyncInfo;
  public
     // Public declarations
     class function Instance: TSyncManager;
     constructor    Create;
     destructor     Destroy; override;
     procedure      AddThread(ThreadSync: TThreadSync);
     procedure      RemoveThread(ThreadSync: TThreadSync);
     procedure      Synchronize(ThreadSync: TThreadSync);
  end;

  // TThreadCounter class
  TThreadCounter    =  class(TObject)
  private
     // Private declarations
     FLock:         TRTLCriticalSection;
     FEmpty:        THandle;
     FCount:        Integer;
  protected
     // Protected declarations
     function       GetCount: Integer;
  public
     // Public declarations
     constructor    Create;
     destructor     Destroy; override;
     procedure      Increment;
     procedure      Decrement;
     procedure      WaitForEmpty;
     property       Count: Integer read GetCount;
  end;

  // TFastMemStream class
  TFastMemStream    =  class(TMemoryStream)
  protected
     // Protected declarations
     function       Realloc(var NewCapacity: Longint): Pointer; override;
  end;

  // Multipacket message handler
  TPipeMultiMsg     =  class(TObject)
  private
     // Private declarations
     FHandle:       THandle;
     FStream:       TStream;
  protected
     // Protected declarations
     procedure      CreateTempBacking;
  public
     // Public declarations
     constructor    Create;
     destructor     Destroy; override;
     property       Stream: TStream read FStream;
  end;

  // TPipeListenThread class
  TPipeListenThread =  class(TThreadEx)
  private
     // Private declarations
     FNotify:       HWND;
     FNotifyThread: THandle;
     FErrorCode:    Integer;
     FPipe:         HPIPE;
     FPipeName:     String;
     FConnected:    Boolean;
     FEvents:       Array [0..1] of THandle;
     FOlapConnect:  TOverlapped;
     FPipeServer:   TPipeServer;
     FSA:           TSecurityAttributes;
  protected
     // Protected declarations
     function       CreateServerPipe: Boolean;
     procedure      DoWorker;
     procedure      Execute; override;
     function       SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;
  public
     // Public declarations
     constructor    Create(PipeServer: TPipeServer; KillEvent: THandle);
     destructor     Destroy; override;
  end;

  // TPipeThread class
  TPipeThread       =  class(TThreadEx)
  private
     // Private declarations
     FServer:       Boolean;
     FNotify:       HWND;
     FNotifyThread: THandle;
     FPipe:         HPIPE;
     FErrorCode:    Integer;
     FCounter:      TThreadCounter;
     FWrite:        DWORD;
     FWriteQueue:   TWriteQueue;
     FPipeWrite:    PPipeWrite;
     FRcvRead:      DWORD;
     FPendingRead:  Boolean;
     FPendingWrite: Boolean;
     FMultiMsg:     TPipeMultiMsg;
     FRcvStream:    TFastMemStream;
     FRcvBuffer:    PChar;
     FRcvAlloc:     DWORD;
     FRcvSize:      DWORD;
     FEvents:       Array [0..3] of THandle;
     FOlapRead:     TOverlapped;
     FOlapWrite:    TOverlapped;
  protected
     // Protected declarations
     function       QueuedRead: Boolean;
     function       CompleteRead: Boolean;
     function       QueuedWrite: Boolean;
     function       CompleteWrite: Boolean;
     procedure      DoMessage;
     procedure      Execute; override;
     function       SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;
  public
     // Public declarations
     constructor    Create(Server: Boolean; NotifyWindow: HWND; NotifyThread: THandle; WriteQueue: TWriteQueue; Counter: TThreadCounter; Pipe: HPIPE; KillEvent: THandle);
     destructor     Destroy; override;
     property       Pipe: HPIPE read FPipe;
  end;

  // TPipeServer component class
  TPipeServer    =  class(TComponent)
  private
     // Private declarations
     FBaseThread:   THandle;
     FHwnd:         HWND;
     FPipeName:     String;
     FDeferActive:  Boolean;
     FActive:       Boolean;
     FInShutDown:   Boolean;
     FKillEv:       THandle;
     FClients:      TList;
     FThreadCount:  TThreadCounter;
     FListener:     TPipeListenThread;
     FSA:           TSecurityAttributes;
     FOPS:          TOnPipeSent;
     FOPC:          TOnPipeConnect;
     FOPD:          TOnPipeDisconnect;
     FOPM:          TOnPipeMessage;
     FOPE:          TOnPipeError;
     procedure      DoStartup;
     procedure      DoShutdown;
  protected
     // Protected declarations
     function       AllocPipeInfo(Pipe: HPIPE): PPipeInfo;
     function       GetClient(Index: Integer): HPIPE;
     function       GetClientCount: Integer;
     function       GetClientInfo(Pipe: HPIPE; out PipeInfo: PPipeInfo): Boolean;
     procedure      WndMethod(var Message: TMessage);
     procedure      RemoveClient(Pipe: HPIPE);
     procedure      SetActive(Value: Boolean);
     procedure      SetPipeName(Value: String);
     procedure      AddWorkerThread(Pipe: HPIPE);
     procedure      RemoveWorkerThread(Sender: TObject);
     procedure      RemoveListenerThread(Sender: TObject);
     procedure      Loaded; override;
  public
     // Public declarations
     constructor    Create(AOwner: TComponent); override;
     constructor    CreateUnowned;
     destructor     Destroy; override;
     function       Broadcast(var Buffer; Count: Integer): Boolean; overload;
     function       Broadcast(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; overload;
     function       Disconnect(Pipe: HPIPE): Boolean;
     function       Write(Pipe: HPIPE; var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; overload;
     function       Write(Pipe: HPIPE; var Buffer; Count: Integer): Boolean; overload;
     function       SendStream(Pipe: HPIPE; Stream: TStream): Boolean;
     property       WindowHandle: HWND read FHwnd;
     property       ClientCount: Integer read GetClientCount;
     property       Clients[Index: Integer]: HPIPE read GetClient;
  published
     // Published declarations
     property       Active: Boolean read FActive write SetActive;
     property       OnPipeSent: TOnPipeSent read FOPS write FOPS;
     property       OnPipeConnect: TOnPipeConnect read FOPC write FOPC;
     property       OnPipeDisconnect: TOnPipeDisconnect read FOPD write FOPD;
     property       OnPipeMessage: TOnPipeMessage read FOPM write FOPM;
     property       OnPipeError: TOnPipeError read FOPE write FOPE;
     property       PipeName: String read FPipeName write SetPipeName;
  end;

  // TPipeClient component class
  TPipeClient    =  class(TComponent)
  private
     // Private declarations
     FBaseThread:   THandle;
     FHwnd:         HWND;
     FPipe:         HPIPE;
     FPipeName:     String;
     FServerName:   String;
     FDisconnecting:Boolean;
     FReply:        Boolean;
     FThrottle:     LongWord;
     FWriteQueue:   TWriteQueue;
     FWorker:       TPipeThread;
     FKillEv:       THandle;
     FSA:           TSecurityAttributes;
     FOPE:          TOnPipeError;
     FOPD:          TOnPipeDisconnect;
     FOPM:          TOnPipeMessage;
     FOPS:          TOnPipeSent;
  protected
     // Protected declarations
     function       GetConnected: Boolean;
     procedure      SetPipeName(Value: String);
     procedure      SetServerName(Value: String);
     procedure      RemoveWorkerThread(Sender: TObject);
     procedure      WndMethod(var Message: TMessage);
  public
     // Public declarations
     constructor    Create(AOwner: TComponent); override;
     constructor    CreateUnowned;
     destructor     Destroy; override;
     function       Connect(WaitTime: DWORD = NMPWAIT_USE_DEFAULT_WAIT; Start: Boolean = True): Boolean;
     function       WaitForReply(TimeOut: Cardinal = INFINITE): Boolean;
     procedure      Disconnect;
     procedure      FlushPipeBuffers;
     function       SendStream(Stream: TStream): Boolean;
     function       Write(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean; overload;
     function       Write(var Buffer; Count: Integer): Boolean; overload;
     property       Connected: Boolean read GetConnected;
     property       WindowHandle: HWND read FHwnd;
     property       Pipe: HPIPE read FPipe;
  published
     // Published declarations
     property       MemoryThrottle: LongWord read FThrottle write FThrottle;
     property       PipeName: String read FPipeName write SetPipeName;
     property       ServerName: String read FServerName write SetServerName;
     property       OnPipeDisconnect: TOnPipeDisconnect read FOPD write FOPD;
     property       OnPipeMessage: TOnPipeMessage read FOPM write FOPM;
     property       OnPipeSent: TOnPipeSent read FOPS write FOPS;
     property       OnPipeError: TOnPipeError read FOPE write FOPE;
  end;

  // TPipeConsoleThread class
  TPipeConsoleThread=  class(TThreadEx)
  private
     // Private declarations
     FNotify:       HWND;
     FStream:       TFastMemStream;
     FProcess:      THandle;
     FOutput:       THandle;
     FError:        THandle;
     procedure      ProcessPipe(Handle: THandle; Msg: UINT);
  protected
     // Protected declarations
     procedure      Execute; override;
     procedure      ProcessPipes;
     function       SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;
  public
     // Public declarations
     constructor    Create(NotifyWindow: HWND; ProcessHandle, OutputPipe, ErrorPipe: THandle);
     destructor     Destroy; override;
  end;

  // TPipeConsole component class
  TPipeConsole      =  class(TComponent)
  private
     // Private declarations
     FRead:         TPipeStdHandles;
     FWrite:        TPipeStdHandles;
     FWorker:       TPipeConsoleThread;
     FPriority:     TThreadPriority;
     FPI:           TProcessInformation;
     FSI:           TStartupInfo;
     FLastErr:      Integer;
     FVisible:      Boolean;
     FStopping:     Boolean;
     FHwnd:         HWND;
     FOnStop:       TOnConsoleStop;
     FOnOutput:     TOnConsole;
     FOnError:      TOnConsole;
     FApplication:  String;
     FCommandLine:  String;
     procedure      ProcessPipe(Handle: THandle; Stream: TStream);
     function       SynchronousRun(OutputStream, ErrorStream: TStream; Timeout: DWORD): DWORD;
  protected
     // Protected declarations
     function       GetConsoleHandle: HWND;
     function       GetRunning: Boolean;
     function       GetVisible: Boolean;
     function       OpenStdPipes: Boolean;
     procedure      CloseStdPipes;
     procedure      ForcePriority(Value: TThreadPriority);
     procedure      RemoveWorkerThread(Sender: TObject);
     procedure      SetLastErr(Value: Integer);
     procedure      SetPriority(Value: TThreadPriority);
     procedure      SetVisible(Value: Boolean);
     procedure      WndMethod(var Message: TMessage);
  public
     // Public declarations
     constructor    Create(AOwner: TComponent); override;
     constructor    CreateUnowned;
     destructor     Destroy; override;
     function       ComSpec: String;
     function       Execute(Application, CommandLine: String; OutputStream, ErrorStream: TStream; Timeout: DWORD = INFINITE): DWORD;
     procedure      SendCtrlBreak;
     procedure      SendCtrlC;
     function       Start(Application, CommandLine: String): Boolean;
     procedure      Stop(ExitValue: DWORD);
     procedure      Write(const Buffer; Length: Integer);
     property       Application: String read FApplication;
     property       CommandLine: String read FCommandLine;
     property       ConsoleHandle: HWND read GetConsoleHandle;
     property       Running: Boolean read GetRunning;
  published
     // Published declarations
     property       LastError: Integer read FLastErr write SetLastErr;
     property       OnError: TOnConsole read FOnError write FOnError;
     property       OnOutput: TOnConsole read FOnOutput write FOnOutput;
     property       OnStop: TOnConsoleStop read FOnStop write FOnStop;
     property       Priority: TThreadPriority read FPriority write SetPriority;
     property       Visible: Boolean read GetVisible write SetVisible;
  end;

////////////////////////////////////////////////////////////////////////////////
//   Console helper functions
////////////////////////////////////////////////////////////////////////////////
function   ExecConsoleEvent(ProcessHandle: THandle; Event: DWORD): Boolean;
procedure  ExitProcessEx(ProcessHandle: THandle; ExitCode: DWORD);
function   GetConsoleWindowEx(ProcessHandle: THandle; ProcessID, ThreadID: DWORD): HWND;

////////////////////////////////////////////////////////////////////////////////
//   Pipe helper functions
////////////////////////////////////////////////////////////////////////////////
function   AllocPipeWrite(const Buffer; Count: Integer): PPipeWrite;
function   AllocPipeWriteWithPrefix(const Prefix; PrefixCount: Integer; const Buffer; Count: Integer): PPipeWrite;
procedure  CheckPipeName(Value: String);
procedure  ClearOverlapped(var Overlapped: TOverlapped; ClearEvent: Boolean = False);
procedure  CloseHandleClear(var Handle: THandle);
function   ComputerName: String;
procedure  DisconnectAndClose(Pipe: HPIPE; IsServer: Boolean = True);
procedure  DisposePipeWrite(var PipeWrite: PPipeWrite);
function   EnumConsoleWindows(Window: HWND; lParam: Integer): BOOL; stdcall;
procedure  FlushMessages;
function   IsHandle(Handle: THandle): Boolean;
procedure  RaiseWindowsError;

////////////////////////////////////////////////////////////////////////////////
//   Security helper functions
////////////////////////////////////////////////////////////////////////////////
procedure  InitializeSecurity(var SA: TSecurityAttributes);
procedure  FinalizeSecurity(var SA: TSecurityAttributes);

////////////////////////////////////////////////////////////////////////////////
//   Object instance functions
////////////////////////////////////////////////////////////////////////////////
function   AllocateHWnd(Method: TWndMethod): HWND;
procedure  DeallocateHWnd(Wnd: HWND);
procedure  FreeObjectInstance(ObjectInstance: Pointer);
function   MakeObjectInstance(Method: TWndMethod): Pointer;

////////////////////////////////////////////////////////////////////////////////
//   Registration function
////////////////////////////////////////////////////////////////////////////////
procedure  Register;

implementation

////////////////////////////////////////////////////////////////////////////////
//   Global protected variables
////////////////////////////////////////////////////////////////////////////////
var
  InstBlockList:    PInstanceBlock       =  nil;
  InstFreeList:     PObjectInstance      =  nil;
  SyncManager:      TSyncManager         =  nil;
  InstCritSect:     TRTLCriticalSection;
  ThreadWndClass:   TWndClass   =  (
                                      style:         0;
                                      lpfnWndProc:   nil;
                                      cbClsExtra:    0;
                                      cbWndExtra:    0;
                                      hInstance:     0;
                                      hIcon:         0;
                                      hCursor:       0;
                                      hbrBackground: 0;
                                      lpszMenuName:  nil;
                                      lpszClassName: 'ThreadSyncWindow');
  ObjWndClass:      TWndClass   =  (
                                      style:         0;
                                      lpfnWndProc:   @DefWindowProc;
                                      cbClsExtra:    0;
                                      cbWndExtra:    0;
                                      hInstance:     0;
                                      hIcon:         0;
                                      hCursor:       0;
                                      hbrBackground: 0;
                                      lpszMenuName:  nil;
                                      lpszClassName: 'ObjWndWindow'
                                   );

//// TPipeConsoleThread ////////////////////////////////////////////////////////
constructor TPipeConsoleThread.Create(NotifyWindow: HWND; ProcessHandle, OutputPipe, ErrorPipe: THandle);
begin

  // Perform inherited create (suspended)
  inherited Create(True);

  // Resource protection
  try
     // Set initial state
     FProcess:=0;
     FNotify:=NotifyWindow;
     FOutput:=OutputPipe;
     FError:=ErrorPipe;
     FStream:=TFastMemStream.Create;
  finally
     // Duplicate the process handle
     DuplicateHandle(GetCurrentProcess, ProcessHandle, GetCurrentProcess, @FProcess, 0, True, DUPLICATE_SAME_ACCESS);
  end;

  // Set thread parameters
  FreeOnTerminate:=True;
  Priority:=tpLower;

end;

destructor TPipeConsoleThread.Destroy;
begin

  // Resource protection
  try
     // Close the process handle
     CloseHandleClear(FProcess);
     // Free the memory stream
     FStream.Free;
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

procedure TPipeConsoleThread.Execute;
var  dwExitCode:    DWORD;
begin

  // Set default return value
  ReturnValue:=ERROR_SUCCESS;

  // Keep looping until the process terminates
  while True do
  begin
     // Wait for specified amount of time
     case WaitForSingleObject(FProcess, DEF_SLEEP) of
        // Object is signaled (process is finished)
        WAIT_OBJECT_0  :
        begin
           // Process the output pipes one last time
           ProcessPipes;
           // Get the process exit code
           if GetExitCodeProcess(FProcess, dwExitCode) then ReturnValue:=dwExitCode;
           // Break the loop
           break;
        end;
        // Timeout, check the output pipes for data
        WAIT_TIMEOUT   :  ProcessPipes;
     else
        // Failure, set return code
        ReturnValue:=GetLastError;
        // Done processing
        break;
     end;
  end;

end;

procedure TPipeConsoleThread.ProcessPipes;
begin

  // Process the output pipe
  ProcessPipe(FOutput, WM_PIPE_CON_OUT);

  // Process the error pipe
  ProcessPipe(FError, WM_PIPE_CON_ERR);

end;

procedure TPipeConsoleThread.ProcessPipe(Handle: THandle; Msg: UINT);
var  dwRead:        DWORD;
     dwSize:        DWORD;
begin

  // Check the pipe for available data
  if PeekNamedPipe(Handle, nil, 0, nil, @dwSize, nil) and (dwSize > 0) then
  begin
     // Set the stream size
     FStream.Size:=dwSize;
     // Resource protection
     try
        // Read from the pipe
        if ReadFile(Handle, FStream.Memory^, dwSize, dwRead, nil) then
        begin
           // Make sure we read the number of bytes specified by size
           if not(dwRead = dwSize) then FStream.Size:=dwRead;
           // Rewind the stream
           FStream.Position:=0;
           // Send the message to the component
           SafeSendMessage(Msg, 0, Integer(FStream));
           // Sleep
           Sleep(0);
        end;
     finally
        // Clear the stream
        FStream.Clear;
     end;
  end;

end;

function TPipeConsoleThread.SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;
begin

  // Check window handle
  if IsWindow(FNotify) then
     // Send the message
     result:=SendMessage(FNotify, Msg, wParam, lParam)
  else
     // Failure
     result:=0;

end;

//// TPipeConsole //////////////////////////////////////////////////////////////
constructor TPipeConsole.Create(AOwner: TComponent);
begin

  // Perform inherited create
  inherited Create(AOwner);

  // Private declarations
  FHwnd:=AllocateHWnd(WndMethod);
  FillChar(FRead, SizeOf(FRead), 0);
  FillChar(FWrite, SizeOf(FWrite), 0);
  FillChar(FPI, SizeOf(FPI), 0);
  FillChar(FSI, SizeOf(FSI), 0);
  FLastErr:=ERROR_SUCCESS;
  FPriority:=tpNormal;
  SetLength(FApplication, 0);
  SetLength(FCommandLine, 0);
  FStopping:=False;
  FVisible:=False;
  FWorker:=nil;

end;

constructor TPipeConsole.CreateUnowned;
begin

  // Perform create with no owner
  Create(nil);

end;

destructor TPipeConsole.Destroy;
begin

  // Resource protection
  try
     // Stop the console application
     Stop(0);
     // Deallocate the window handle
     DeallocateHwnd(FHwnd);
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

procedure TPipeConsole.SetLastErr(Value: Integer);
begin

  // Resource protection
  try
     // Set the last error for the thread
     SetLastError(Value);
  finally
     // Update the last error status
     FLastErr:=Value;
  end;

end;

function TPipeConsole.ComSpec: String;
begin

  // Allocate buffer for result
  SetLength(result, MAX_PATH);

  // Resource protection
  try
     // Get the environment variable for COMSPEC and truncate to actual result
     SetLength(result, GetEnvironmentVariable(PChar(resComSpec), Pointer(result), MAX_PATH));
  finally
     // Capture the last error code
     FLastErr:=GetLastError;
  end;

end;

function TPipeConsole.OpenStdPipes: Boolean;
var  dwIndex:       Integer;
begin

  // Set default result
  result:=False;

  // Resource protection
  try
     // Close any open handles
     CloseStdPipes;
     // Resource protection
     try
        // Iterate the pipe array and create new read / write pipe handles
        for dwIndex:=STD_PIPE_INPUT to STD_PIPE_ERROR do
        begin
           // Create the pipes
           if CreatePipe(FRead[dwIndex], FWrite[dwIndex], nil, MAX_BUFFER) then
           begin
              // Duplicate the read handles so they can be inherited
              if DuplicateHandle(GetCurrentProcess, FRead[dwIndex], GetCurrentProcess, @FRead[dwIndex], 0, True, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS) then
                 // Duplicate the write handles so they can be inherited
                 result:=DuplicateHandle(GetCurrentProcess, FWrite[dwIndex], GetCurrentProcess, @FWrite[dwIndex], 0, True, DUPLICATE_CLOSE_SOURCE or DUPLICATE_SAME_ACCESS)
              else
                 // Failed to duplicate
                 result:=False;
           end
           else
              // Failed to create pipes
              result:=False;
           // Should we continue?
           if not(result) then break;
        end;
     finally
        // Capture the last error code
        FLastErr:=GetLastError;
     end;
  finally
     // Close all handles on failure
     if not(result) then CloseStdPipes;
  end;

end;

procedure TPipeConsole.CloseStdPipes;
var  dwIndex:       Integer;
begin

  // Iterate the pipe array and close the read / write pipe handles
  for dwIndex:=STD_PIPE_INPUT to STD_PIPE_ERROR do
  begin
     // Close and clear the read handle
     CloseHandleClear(FRead[dwIndex]);
     // Close and clear the read handle
     CloseHandleClear(FWrite[dwIndex]);
  end;

end;

function TPipeConsole.GetRunning: Boolean;
begin

  // Check process information
  result:=(IsHandle(FPI.hProcess) and (WaitForSingleObject(FPI.hProcess, 0) = WAIT_TIMEOUT));

end;

procedure TPipeConsole.SendCtrlBreak;
begin

  // Make sure the process is running, then inject and exec
  if GetRunning then ExecConsoleEvent(FPI.hProcess, CTRL_BREAK_EVENT);

end;

procedure TPipeConsole.SendCtrlC;
begin

  // Make sure the process is running, then inject and exec
  if GetRunning then ExecConsoleEvent(FPI.hProcess, CTRL_C_EVENT);

end;

procedure TPipeConsole.Write(const Buffer; Length: Integer);
var  dwWrite:       DWORD;
begin

  // Check state
  if GetRunning and IsHandle(FWrite[STD_PIPE_INPUT]) then
  begin
     // Write data to the pipe
     WriteFile(FWrite[STD_PIPE_INPUT], Buffer, Length, dwWrite, nil);
  end;

end;

function TPipeConsole.GetConsoleHandle: HWND;
var  lpConInfo:     TPipeConsoleInfo;
begin

  // Clear the return handle
  result:=0;

  // Check to see if running
  if GetRunning then
  begin
     // Clear the window handle
     lpConInfo.Window:=0;
     // Resource protection
     try
        // Set process info
        lpConInfo.ProcessID:=FPI.dwProcessID;
        lpConInfo.ThreadID:=FPI.dwThreadID;
        // Enumerate the windows on the console thread
        EnumWindows(@EnumConsoleWindows, Integer(@lpConInfo));
     finally
        // Return the window handle
        result:=lpConInfo.Window;
     end;
  end;

end;

function TPipeConsole.GetVisible: Boolean;
var  hwndCon:       HWND;
begin

  // Check running state
  if not(GetRunning) then
     // If not running then return the stored state
     result:=FVisible
  else
  begin
     // Attempt to get the window handle
     hwndCon:=GetConsoleWindowEx(FPI.hProcess, FPI.dwProcessId, FPI.dwThreadId);
     // Check result
     if IsWindow(hwndCon) then
        // Return visible state
        result:=IsWindowVisible(hwndCon)
     else
        // Return stored state
        result:=FVisible;
  end;

end;

procedure TPipeConsole.ForcePriority(Value: TThreadPriority);
const   Priorities: Array [TThreadPriority] of Integer =
                          (
                             THREAD_PRIORITY_IDLE,
                             THREAD_PRIORITY_LOWEST,
                             THREAD_PRIORITY_BELOW_NORMAL,
                             THREAD_PRIORITY_NORMAL,
                             THREAD_PRIORITY_ABOVE_NORMAL,
                             THREAD_PRIORITY_HIGHEST,
                             THREAD_PRIORITY_TIME_CRITICAL
                          );
begin

  // Check running state
  if not(GetRunning) then
     // Update the value
     FPriority:=Value
  else
  begin
     // Get the thread handle
     if SetThreadPriority(FPI.hThread, Priorities[Value]) then
     begin
        // Priority was set, persist value
        FPriority:=Value;
     end;
  end;

end;

procedure TPipeConsole.SetPriority(Value: TThreadPriority);
begin

  // Check against current value
  if (FPriority <> Value) then ForcePriority(Value);

end;

procedure TPipeConsole.SetVisible(Value: Boolean);
var  hwndCon:       HWND;
begin

  // Check against current state
  if not(GetVisible = Value) then
  begin
     // Update the state
     FVisible:=Value;
     // Check to see if running
     if GetRunning then
     begin
        // Attempt to have the console window return us its handle
        hwndCon:=GetConsoleWindowEx(FPI.hProcess, FPI.dwProcessId, FPI.dwThreadId);
        // Check result
        if IsWindow(hwndCon) then
        begin
           // Show or hide based on visibility
           if FVisible then
              // Show
              ShowWindow(hwndCon, SW_SHOWNORMAL)
           else
              // Hide
              ShowWindow(hwndCon, SW_HIDE);
        end;
     end;
  end;

end;

procedure TPipeConsole.WndMethod(var Message: TMessage);
begin

  // Handle the pipe messages
  case Message.Msg of
     // Pipe output from console
     WM_PIPE_CON_OUT   :  if Assigned(FOnOutput) then FOnOutput(Self, TStream(Pointer(Message.lParam)));
     // Pipe error from console
     WM_PIPE_CON_ERR   :  if Assigned(FOnError) then FOnError(Self, TStream(Pointer(Message.lParam)));
     // Shutdown
     WM_DOSHUTDOWN     :  Stop(Message.WParam);
  else
     // Call default window procedure
     Message.Result:=DefWindowProc(FHwnd, Message.Msg, Message.wParam, Message.lParam);
  end;

end;

procedure TPipeConsole.RemoveWorkerThread(Sender: TObject);
var  dwReturn:      LongWord;
begin

  // Get the thread return value
  dwReturn:=FWorker.ReturnValue;

  // Resource protection
  try
     // Set thread variable to nil
     FWorker:=nil;
     // Resource protection
     try
        // Notify of process stop
        if (not(csDestroying in ComponentState) and Assigned(FOnStop)) then FOnStop(Self, dwReturn);
     finally
        // Close the process and thread handles
        CloseHandleClear(FPI.hProcess);
        CloseHandleClear(FPI.hThread);
     end;
  finally
     // Close the pipe handles
     CloseStdPipes;
  end;

end;

procedure TPipeConsole.ProcessPipe(Handle: THandle; Stream: TStream);
var  lpszBuffer:    PChar;
     dwRead:        DWORD;
     dwSize:        DWORD;
begin

  // Check the pipe for available data
  if PeekNamedPipe(Handle, nil, 0, nil, @dwSize, nil) and (dwSize > 0) then
  begin
     // Allocate buffer for read. Note, we need to clear the output even if no stream is passed
     lpszBuffer:=AllocMem(dwSize);
     // Resource protection
     try
        // Read from the pipe
        if ReadFile(Handle, lpszBuffer^, dwSize, dwRead, nil) and Assigned(Stream) then
        begin
           // Save buffer to stream
           Stream.Write(lpszBuffer^, dwRead);
        end;
     finally
        // Free the memory
        FreeMem(lpszBuffer);
     end;
  end;

end;

function TPipeConsole.SynchronousRun(OutputStream, ErrorStream: TStream; Timeout: DWORD): DWORD;
begin

  // Set default return value
  SetLastErr(ERROR_SUCCESS);

  // Resource protection
  try
     // Keep looping until the process terminates
     while True do
     begin
        // Wait for specified amount of time
        case WaitForSingleObject(FPI.hProcess, DEF_SLEEP) of
           // Object is signaled (process is finished)
           WAIT_OBJECT_0  :
           begin
              // Process the output pipes one last time
              ProcessPipe(FRead[STD_PIPE_OUTPUT], OutputStream);
              ProcessPipe(FRead[STD_PIPE_ERROR], ErrorStream);
              // Break the loop
              break;
           end;
           // Timeout, check the output pipes for data
           WAIT_TIMEOUT   :
           begin
              // Process the output pipes
              ProcessPipe(FRead[STD_PIPE_OUTPUT], OutputStream);
              ProcessPipe(FRead[STD_PIPE_ERROR], ErrorStream);
           end;
        else
           // Failure, set return code
           SetLastErr(GetLastError);
           // Done processing
           break;
        end;
        // Check the timeout
        if (Timeout > 0) and (GetTickCount > Timeout) then
        begin
           // Terminate the process
           ExitProcessEx(FPI.hProcess, 0);
           // Set result
           SetLastErr(ERROR_TIMEOUT);
           // Done processing
           break;
        end;
     end;
  finally
     // Return last error result
     result:=FLastErr;
  end;

end;

function TPipeConsole.Execute(Application, CommandLine: String; OutputStream, ErrorStream: TStream; Timeout: DWORD = INFINITE): DWORD;
begin

  // Set default result
  SetLastErr(ERROR_SUCCESS);

  // Both params cannot be null
  if (Length(Application) = 0) and (Length(CommandLine) = 0) then
  begin
     // Set error code
     SetLastErr(ERROR_INVALID_PARAMETER);
     // Failure
     result:=FLastErr;
  end
  else
  begin
     // Stop existing process if running
     Stop(0);
     // Resource protection
     try
        // Clear the process information
        FillChar(FPI, SizeOf(FPI), 0);
        // Clear the startup info structure
        FillChar(FSI, SizeOf(FSI), 0);
        // Attempt to open the pipes for redirection
        if OpenStdPipes then
        begin
           // Resource protection
           try
              // Set structure size
              FSI.cb:=SizeOf(FSI);
              // Set flags
              FSI.dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
              // Determine if the process will be shown or hidden
              if FVisible then
                 // Show flag
                 FSI.wShowWindow:=SW_SHOWNORMAL
              else
                 // Hide flag
                 FSI.wShowWindow:=SW_HIDE;
              // Set the redirect handles
              FSI.hStdInput:=FRead[STD_PIPE_INPUT];
              FSI.hStdOutput:=FWrite[STD_PIPE_OUTPUT];
              FSI.hStdError:=FWrite[STD_PIPE_ERROR];
              // Create the process
              if CreateProcess(Pointer(Application), Pointer(CommandLine), nil, nil, True, CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP or NORMAL_PRIORITY_CLASS, nil, nil, FSI, FPI) then
              begin
                 // Resource protection
                 try
                    // Set the priority
                    if (FPriority <> tpNormal) then ForcePriority(FPriority);
                    // Wait for input idle
                    WaitForInputIdle(FPI.hProcess, INFINITE);
                    // Check timeout value
                    if (Timeout = INFINITE) then
                       // Synchronous loop with no timeout
                       SynchronousRun(OutputStream, ErrorStream, 0)
                    else
                       // Synchronous loop with timeout
                       SynchronousRun(OutputStream, ErrorStream, GetTickCount + Timeout)
                 finally
                    // Close the process and thread handle
                    CloseHandleClear(FPI.hProcess);
                    CloseHandleClear(FPI.hThread);
                 end;
              end
              else
                 // Set the last error
                 SetLastErr(GetLastError);
           finally
              // Close the pipe handles
              CloseStdPipes;
           end;
        end;
     finally
        // Return last error code
        result:=FLastErr;
     end;
  end;

end;

function TPipeConsole.Start(Application, CommandLine: String): Boolean;
begin

  // Both params cannot be null
  if (Length(Application) = 0) and (Length(CommandLine) = 0) then
  begin
     // Set error code
     SetLastErr(ERROR_INVALID_PARAMETER);
     // Failure
     result:=False;
  end
  else
  begin
     // Stop existing process if running
     Stop(0);
     // Resource protection
     try
        // Clear the process information
        FillChar(FPI, SizeOf(FPI), 0);
        // Clear the startup info structure
        FillChar(FSI, SizeOf(FSI), 0);
        // Attempt to open the pipes for redirection
        if OpenStdPipes then
        begin
           // Set structure size
           FSI.cb:=SizeOf(FSI);
           // Set flags
           FSI.dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
           // Determine if the process will be shown or hidden
           if FVisible then
              // Show flag
              FSI.wShowWindow:=SW_SHOWNORMAL
           else
              // Hide flag
              FSI.wShowWindow:=SW_HIDE;
           // Set the redirect handles
           FSI.hStdInput:=FRead[STD_PIPE_INPUT];
           FSI.hStdOutput:=FWrite[STD_PIPE_OUTPUT];
           FSI.hStdError:=FWrite[STD_PIPE_ERROR];
           // Create the process
           if CreateProcess(Pointer(Application), Pointer(CommandLine), nil, nil, True, CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP or NORMAL_PRIORITY_CLASS, nil, nil, FSI, FPI) then
           begin
              // Persist the strings used to start the process
              FApplication:=Application;
              FCommandLine:=CommandLine;
              // Set the priority
              if (FPriority <> tpNormal) then ForcePriority(FPriority);
              // Wait for input idle
              WaitForInputIdle(FPI.hProcess, INFINITE);
              // Exception trap
              try
                 // Process is created, now start the worker thread
                 FWorker:=TPipeConsoleThread.Create(FHwnd, FPI.hProcess, FRead[STD_PIPE_OUTPUT], FRead[STD_PIPE_ERROR]);
                 // Resource protection
                 try
                    // Set the OnTerminate handler
                    FWorker.OnTerminate:=RemoveWorkerThread;
                 finally
                    // Resume the worker thread
                    FWorker.Resume;
                 end;
              except
                 // Stop the process
                 Stop(0);
              end;
           end
           else
              // Get the last error
              SetLastErr(GetLastError);
        end;
     finally
        // Check final running state
        result:=Assigned(FWorker);
     end;
  end;

end;

procedure TPipeConsole.Stop(ExitValue: DWORD);
begin

  // Check to see if still running
  if GetRunning and not(FStopping) then
  begin
     // Check to see if in a send message
     if InSendMessage then
        // Defered shutdown
        PostMessage(FHwnd, WM_DOSHUTDOWN, ExitValue, 0)
     else
     begin
        // Set state
        FStopping:=True;
        // Resource protection
        try
           // Clear strings
           SetLength(FApplication, 0);
           SetLength(FCommandLine, 0);
           // Resource protection
           try
              // Force the process to close
              ExitProcessEx(FPI.hProcess, ExitValue);
              // Wait for thread to finish up
              if Assigned(FWorker) then FWorker.Wait;
           finally
              // Close the process and thread handle
              CloseHandleClear(FPI.hProcess);
              CloseHandleClear(FPI.hThread);
              // Close the pipe handles
              CloseStdPipes;
           end;
        finally
           // Reset the stopping flag
           FStopping:=False;
        end;
     end;
  end;

end;

//// TPipeClient ///////////////////////////////////////////////////////////////
constructor TPipeClient.Create(AOwner: TComponent);
begin

  // Perform inherited
  inherited Create(AOwner);

  // Set defaults
  InitializeSecurity(FSA);
  FKillEv:=CreateEvent(@FSA, True, False, nil);
  FPipe:=INVALID_HANDLE_VALUE;
  FDisconnecting:=False;
  FBaseThread:=GetCurrentThreadID;
  FThrottle:=DEF_MEMTHROTTLE;
  FWriteQueue:=TWriteQueue.Create;
  FWorker:=nil;
  FPipeName:=resPipeName;
  FServerName:=EmptyStr;
  FHwnd:=AllocateHWnd(WndMethod);

end;

constructor TPipeClient.CreateUnowned;
begin

  // Perform create with no owner
  Create(nil);

end;

destructor TPipeClient.Destroy;
begin

  // Resource protection
  try
     // Disconnect the pipe
     Disconnect;
     // Close the event handle
     CloseHandle(FKillEv);
     // Free the write queue
     FWriteQueue.Free;
     // Free memory resources
     FinalizeSecurity(FSA);
     // Deallocate the window handle
     DeAllocateHWnd(FHwnd);
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

function TPipeClient.GetConnected: Boolean;
var  dwExit:        DWORD;
begin

  // Check worker thread
  if Assigned(FWorker) then
     // Check exit state
     result:=GetExitCodeThread(FWorker.Handle, dwExit) and (dwExit = STILL_ACTIVE)
  else
     // Not connected
     result:=False;

end;

function TPipeClient.Connect(WaitTime: DWORD = NMPWAIT_USE_DEFAULT_WAIT; Start: Boolean = True): Boolean;
var  szName:        String;
     dwMode:        DWORD;
begin

  // Resource protection
  try
     // Check current connected state
     if not(GetConnected) then
     begin
        // Check existing pipe handle
        if IsHandle(FPipe) then
        begin
           // Check Start mode
           if Start then
           begin
              // Pipe was already created, start worker thread against it
              try
                 // Create thread to handle the pipe IO
                 FWorker:=TPipeThread.Create(False, FHwnd, FBaseThread, FWriteQueue, nil, FPipe, FKillEv);
                 // Resource protection
                 try
                    // Set the OnTerminate handler
                    FWorker.OnTerminate:=RemoveWorkerThread;
                 finally;
                    // Resume the thread
                    FWorker.Resume;
                 end;
              except
                 // Free the worker thread
                 FreeAndNil(FWorker);
                 // Close the pipe handle
                 CloseHandleClear(FPipe);
              end;
           end;
        end
        else
        begin
           // Check name against local computer name first
           if (Length(FServerName) = 0) or (CompareText(ComputerName, FServerName) = 0) then
              // Set base local pipe name
              szName:=resPipeBaseName + FPipeName
           else
              // Set base pipe name using specified server
              szName:=Format(resPipeBaseFmtName, [FServerName]) + FPipeName;
           // Attempt to wait for the pipe first
           if WaitNamedPipe(PChar(szName), WaitTime) then
           begin
              // Attempt to create client side handle
              FPipe:=CreateFile(PChar(szName), GENERIC_READ or GENERIC_WRITE, 0, @FSA, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0);
              // Success if we have a valid handle
              if IsHandle(FPipe) then
              begin
                 // Set the pipe read mode flags
                 dwMode:=PIPE_READMODE_MESSAGE or PIPE_WAIT;
                 // Update the pipe
                 SetNamedPipeHandleState(FPipe, dwMode, nil, nil);
                 // Check Start mode
                 if Start then
                 begin
                    // Resource protection
                    try
                       // Create thread to handle the pipe IO
                       FWorker:=TPipeThread.Create(False, FHwnd, FBaseThread, FWriteQueue, nil, FPipe, FKillEv);
                       // Resource protection
                       try
                          // Set the OnTerminate handler
                          FWorker.OnTerminate:=RemoveWorkerThread;
                       finally;
                          // Resume the thread
                          FWorker.Resume;
                       end;
                    except
                       // Free the worker thread
                       FreeAndNil(FWorker);
                       // Close the pipe handle
                       CloseHandleClear(FPipe);
                    end;
                 end;
              end;
           end;
        end;
     end;
  finally
     // Check connected state, or valid handle
     result:=GetConnected or IsHandle(FPipe);
  end;

end;

procedure TPipeClient.Disconnect;
begin

  // Check connected state
  if (GetConnected and not(FDisconnecting)) then
  begin
     // Check to see if processing a message from another thread
     if InSendMessage then
        // Defered shutdown
        PostMessage(FHwnd, WM_DOSHUTDOWN, 0, 0)
     else
     begin
        // Set disconnecting flag
        FDisconnecting:=True;
        // Resource protection
        try
           // Resource protection
           try
              // Check worker thread
              if Assigned(FWorker) then
              begin
                 // Resource protection
                 try
                    // Signal the kill event for the thread
                    SetEvent(FKillEv);
                 finally
                    // Wait for the thread to complete
                    FWorker.Wait;
                 end;
              end;
           finally
              // Clear pipe handle
              FPipe:=INVALID_HANDLE_VALUE;
           end;
        finally
           // Toggle flag
           FDisconnecting:=False;
        end;
     end;
  end
  // Check pipe handle
  else if IsHandle(FPipe) then
     // Close handle
     CloseHandleClear(FPipe);

end;

procedure TPipeClient.FlushPipeBuffers;
var  hEvent:        THandle;
begin

  // Make sure we are not being called from one of the events
  if not(InSendMessage) then
  begin
     // Get the event handle for the empty state
     hEvent:=FWriteQueue.EmptyEvent;
     // While the worker thread is running
     while GetConnected do
     begin
        // Wait until the empty flag is set or we get a message
        case MsgWaitForMultipleObjects(1, hEvent, False, INFINITE, QS_SENDMESSAGE) of
           // Empty event is signalled
           WAIT_OBJECT_0     :  break;
           // Messages waiting to be read
           WAIT_OBJECT_0 + 1 :  FlushMessages;
        end;
     end;
  end;

end;

function TPipeClient.WaitForReply(TimeOut: Cardinal = INFINITE): Boolean;
var  lpMsg:         TMsg;
     dwMark:        LongWord;
begin

  // Clear reply flag
  FReply:=False;

  // Resource protection
  try
     // Make sure we are not being called from one of the events
     if not(InSendMessage) then
     begin
        // Get current tick count
        dwMark:=GetTickCount;
        // Check connected state
        while not(FReply) and GetConnected do
        begin
           // Check for timeout
           if not(TimeOut = INFINITE) and ((GetTickCount - dwMark) >= TimeOut) then break;
           // Peek message from the queue
           if PeekMessage(lpMsg, 0, WM_PIPEMINMSG, WM_PIPEMAXMSG, PM_REMOVE) then
           begin
              // Translate the message
              TranslateMessage(lpMsg);
              // Dispatch the message
              DispatchMessage(lpMsg);
           end;
        end;
     end;
  finally
     // Is the reply flag set
     result:=FReply;
  end;

end;

function TPipeClient.SendStream(Stream: TStream): Boolean;
var  lpszBuffer:    PChar;
     dwRead:        Integer;
begin

  // Check stream and current state
  if Assigned(Stream) and GetConnected then
  begin
     // Set default result
     result:=True;
     // Resource protection
     try
        // Enqueue the start packet
        FWriteQueue.EnqueueStartPacket;
        // Resource protection
        try
           // Allocate buffer for sending
           lpszBuffer:=AllocMem(MAX_BUFFER);
           // Resource protection
           try
              // Set stream position
              Stream.Position:=0;
              // Queue the first read
              dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER);
              // While data
              while (dwRead > 0) and result do
              begin
                 // Write the data
                 if Write(lpszBuffer^, dwRead) then
                    // Seed next data
                    dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER)
                 else
                    // Failed to write the data
                    result:=False;
              end;
           finally
              // Free memory
              FreeMem(lpszBuffer);
           end;
        finally
           // Enqueue the end packet
           FWriteQueue.EnqueueEndPacket;
        end;
     finally
        // Flush the buffers
        FlushPipeBuffers;
     end;
  end
  else
     // Invalid param or state
     result:=False;

end;

function TPipeClient.Write(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean;
begin

  // Check for memory throttling
  if ((FThrottle > 0) and (FWriteQueue.DataSize > FThrottle) and GetConnected) then FlushPipeBuffers;

  // Check connected state
  if GetConnected then
  begin
     // Resource protection
     try
        // Queue the data
        FWriteQueue.Enqueue(AllocPipeWriteWithPrefix(Prefix, PrefixCount, Buffer, Count));
     finally
        // Success
        result:=True;
     end;
  end
  else
     // Not connected
     result:=False;

end;

function TPipeClient.Write(var Buffer; Count: Integer): Boolean;
begin

  // Check for memory throttling
  if ((FThrottle > 0) and (FWriteQueue.DataSize > FThrottle) and GetConnected) then FlushPipeBuffers;

  // Check connected state
  if GetConnected then
  begin
     // Resource protection
     try
        // Queue the data
        FWriteQueue.Enqueue(AllocPipeWrite(Buffer, Count));
     finally
        // Success
        result:=True;
     end;
  end
  else
     // Not connected
     result:=False;

end;

procedure TPipeClient.SetPipeName(Value: String);
begin

  // Check connected state and pipe handle
  if GetConnected or IsHandle(FPipe) then
     // Raise exception
     raise EPipeException.CreateRes(@resPipeConnected)
  else
  begin
     // Check the pipe name
     CheckPipeName(Value);
     // Set the pipe name
     FPipeName:=Value;
  end;

end;

procedure TPipeClient.SetServerName(Value: String);
begin

  // Check connected state and pipe handle
  if GetConnected or IsHandle(FPipe) then
     // Raise exception
     raise EPipeException.CreateRes(@resPipeConnected)
  else
     // Set the server name
     FServerName:=Value;

end;

procedure TPipeClient.RemoveWorkerThread(Sender: TObject);
begin

  // Set thread variable to nil
  FWorker:=nil;

  // Resource protection
  try
     // Notify of disconnect
     if (not(csDestroying in ComponentState) and Assigned(FOPD)) then FOPD(Self, FPipe);
     // Clear the write queue
     FWriteQueue.Clear;
  finally
     // Invalidate handle
     FPipe:=INVALID_HANDLE_VALUE;
  end;

end;

procedure TPipeClient.WndMethod(var Message: TMessage);
begin

  // Handle the pipe messages
  case Message.Msg of
     // Pipe worker error
     WM_PIPEERROR_W    :  if Assigned(FOPE) then FOPE(Self, Message.wParam, pcWorker, Message.lParam);
     // Pipe data sent
     WM_PIPESEND       :  if Assigned(FOPS) then FOPS(Self, Message.wParam, Message.lParam);
     // Pipe data read
     WM_PIPEMESSAGE    :
     begin
        // Set reply flag
        FReply:=True;
        // Fire event
        if Assigned(FOPM) then FOPM(Self, Message.wParam, TStream(Pointer(Message.lParam)));
     end;
     // Raise exception
     WM_THREADCTX      :  raise EPipeException.CreateRes(@resThreadCtx);
     // Disconect
     WM_DOSHUTDOWN     :  Disconnect;
  else
     // Call default window procedure
     Message.Result:=DefWindowProc(FHwnd, Message.Msg, Message.wParam, Message.lParam);
  end;

end;

//// TPipeServer ////////////////////////////////////////////////////////////
constructor TPipeServer.Create(AOwner: TComponent);
begin

  // Perform inherited
  inherited Create(AOwner);

  // Initialize the security attributes
  InitializeSecurity(FSA);

  // Set staring defaults
  FHwnd:=AllocateHWnd(WndMethod);
  FBaseThread:=GetCurrentThreadID;
  FPipeName:=resPipeName;
  FActive:=False;
  FDeferActive:=False;
  FInShutDown:=False;
  FKillEv:=CreateEvent(@FSA, True, False, nil);
  FClients:=TList.Create;
  FThreadCount:=TThreadCounter.Create;
  FListener:=nil;

end;

constructor TPipeServer.CreateUnowned;
begin

  // Perform inherited create with no owner
  Create(nil);

end;

destructor TPipeServer.Destroy;
begin

  // Resource protection
  try
     // Perform the shutdown if active
     Active:=False;
     // Close the event handle
     CloseHandle(FKillEv);
     // Free the clients list
     FClients.Free;
     // Free the thread counter
     FThreadCount.Free;
     // Cleanup memory
     FinalizeSecurity(FSA);
     // Deallocate the window
     DeAllocateHWnd(FHwnd);
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

procedure TPipeServer.WndMethod(var Message: TMessage);
begin

  // Handle the pipe messages
  case Message.Msg of
     // Listener thread error
     WM_PIPEERROR_L    :  if Assigned(FOPE) then FOPE(Self, Message.wParam, pcListener, Message.lParam);
     // Worker thread error
     WM_PIPEERROR_W    :  if Assigned(FOPE) then FOPE(Self, Message.wParam, pcWorker, Message.lParam);
     // Pipe connected
     WM_PIPECONNECT    :  if Assigned(FOPC) then FOPC(Self, Message.wParam);
     // Data message sent on pipe
     WM_PIPESEND       :  if Assigned(FOPS) then FOPS(Self, Message.wParam, Message.lParam);
     // Data message recieved on pipe
     WM_PIPEMESSAGE    :  if Assigned(FOPM) then FOPM(Self, Message.wParam, TStream(Pointer(Message.lParam)));
     // Raise exception
     WM_THREADCTX      :  raise EPipeException.CreateRes(@resThreadCtx);
     // Disconect
     WM_DOSHUTDOWN     :  Active:=False;
  else
     // Call default window procedure
     Message.Result:=DefWindowProc(FHwnd, Message.Msg, Message.wParam, Message.lParam);
  end;

end;

function TPipeServer.GetClientInfo(Pipe: HPIPE; out PipeInfo: PPipeInfo): Boolean;
var  dwIndex:       Integer;
begin

  // Clear outbound param
  PipeInfo:=nil;

  // Resource protection
  try
     // Locate the pipe info record for the given pipe first
     for dwIndex:=Pred(FClients.Count) downto 0 do
     begin
        // Check pipe info pointer
        if (PPipeInfo(FClients[dwIndex])^.Pipe = Pipe) then
        begin
           // Found the record
           PipeInfo:=PPipeInfo(FClients[dwIndex]);
           // Done processing
           break;
        end;
     end;
  finally
     // Success if we have the record
     result:=Assigned(PipeInfo);
  end;

end;

function TPipeServer.GetClient(Index: Integer): HPIPE;
begin

  // Return the requested pipe
  result:=PPipeInfo(FClients[Index])^.Pipe;

end;

function TPipeServer.GetClientCount: Integer;
begin

  // Return the number of client pipes
  result:=FClients.Count;

end;

function TPipeServer.Broadcast(var Buffer; Count: Integer): Boolean;
var  dwIndex:       Integer;
     dwCount:       Integer;
begin

  // Set count
  dwCount:=0;

  // Resource protection
  try
     // Iterate the pipes and write the data to each one
     for dwIndex:=Pred(FClients.Count) downto 0 do
     begin
        // Fail if a write fails
        if Write(Clients[dwIndex], Buffer, Count) then
           // Update count
           Inc(dwCount)
        else
           // Failed, break out
           break;
     end;
  finally
     // Success if all pipes got the message
     result:=(dwCount = FClients.Count);
  end;

end;

function TPipeServer.Broadcast(var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean;
var  dwIndex:       Integer;
     dwCount:       Integer;
begin

  // Set count
  dwCount:=0;

  // Resource protection
  try
     // Iterate the pipes and write the data to each one
     for dwIndex:=Pred(FClients.Count) downto 0 do
     begin
        // Fail if a write fails
        if Write(Clients[dwIndex], Prefix, PrefixCount, Buffer, Count) then
           // Update count
           Inc(dwCount)
        else
           // Failed, break out
           break;
     end;
  finally
     // Success if all pipes got the message
     result:=(dwCount = FClients.Count);
  end;

end;

function TPipeServer.Write(Pipe: HPIPE; var Prefix; PrefixCount: Integer; var Buffer; Count: Integer): Boolean;
var  ppiClient:     PPipeInfo;
begin

  // Get the pipe info
  if GetClientInfo(Pipe, ppiClient) then
  begin
     // Queue the data
     ppiClient.WriteQueue.Enqueue(AllocPipeWriteWithPrefix(Prefix, PrefixCount, Buffer, Count));
     // Success
     result:=True;
  end
  else
     // No client info
     result:=False;

end;

function TPipeServer.Write(Pipe: HPIPE; var Buffer; Count: Integer): Boolean;
var  ppiClient:     PPipeInfo;
begin

  // Get the pipe info
  if GetClientInfo(Pipe, ppiClient) then
  begin
     // Queue the data
     ppiClient.WriteQueue.Enqueue(AllocPipeWrite(Buffer, Count));
     // Success
     result:=True;
  end
  else
     // No client info
     result:=False;

end;

function TPipeServer.SendStream(Pipe: HPIPE; Stream: TStream): Boolean;
var  ppiClient:     PPipeInfo;
     lpszBuffer:    PChar;
     dwRead:        Integer;
begin

  // Check stream and current state
  if Assigned(Stream) and GetClientInfo(Pipe, ppiClient) then
  begin
     // Resource protection
     try
        // Enqueue the start packet
        ppiClient^.WriteQueue.EnqueueStartPacket;
        // Resource protection
        try
           // Allocate buffer for sending
           lpszBuffer:=AllocMem(MAX_BUFFER);
           // Resource protection
           try
              // Set stream position
              Stream.Position:=0;
              // Queue the first read
              dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER);
              // While data
              while (dwRead > 0) do
              begin
                 // Enqueue the data
                 ppiClient^.WriteQueue.Enqueue(AllocPipeWrite(lpszBuffer^, dwRead));
                 // Seed next data
                 dwRead:=Stream.Read(lpszBuffer^, MAX_BUFFER)
              end;
           finally
              // Free memory
              FreeMem(lpszBuffer);
           end;
        finally
           // Enqueue the end packet
           ppiClient^.WriteQueue.EnqueueEndPacket;
        end;
     finally
        // Set default result
        result:=True;
     end;
  end
  else
     // Invalid param or state
     result:=False;

end;

procedure TPipeServer.RemoveClient(Pipe: HPIPE);
var  ppiClient:     PPipeInfo;
begin

  // Attempt to get the pipe info
  if GetClientInfo(Pipe, ppiClient) then
  begin
     // Remove from the client list
     FClients.Remove(ppiClient);
     // Resource protection
     try
        // Resource protection
        try
           // Free the write queue
           ppiClient^.WriteQueue.Free;
           // Close the event handle
           CloseHandle(ppiClient^.KillEvent);
        finally
           // Free the client record
           FreeMem(ppiClient);
        end;
     finally
        // Call the OnDisconnect if assigned and not destroying
        if not(csDestroying in ComponentState) and Assigned(FOPD) then FOPD(Self, Pipe);
     end;
  end;

end;

function TPipeServer.Disconnect(Pipe: HPIPE): Boolean;
var  ppiClient:     PPipeInfo;
     dwIndex:       Integer;
begin

  // Set default result
  result:=True;

  // Check pipe passed in
  if (Pipe = 0) then
  begin
     // Disconnect all
     for dwIndex:=Pred(FClients.Count) downto 0 do
     begin
        // Signal the kill event
        SetEvent(PPipeInfo(FClients[dwIndex])^.KillEvent);
     end;
  end
  // Get the specifed pipe info
  else if GetClientInfo(Pipe, ppiClient) then
     // Set the kill event
     SetEvent(ppiClient^.KillEvent)
  else
     // Failed to locate the pipe
     result:=False;

end;

procedure TPipeServer.Loaded;
begin

  // Perform inherited
  inherited;

  // Set deferred active state
  SetActive(FDeferActive);

end;

procedure TPipeServer.SetActive(Value: Boolean);
begin

  // Check against current state
  if not(FActive = Value) then
  begin
     // Check loaded state
     if (csLoading in ComponentState) then
        // Set deferred state
        FDeferActive:=Value
     // Check designing state. The problem is that in the IDE, a count on the
     // handle will be left open and cause us issues with client connections when
     // running in debugger.
     else if (csDesigning in ComponentState) then
        // Just update the value
        FActive:=Value
     else if (Value) then
        // Perform startup
        DoStartup
     else
        // Perform shutdown
        DoShutdown;
  end;

end;

procedure TPipeServer.SetPipeName(Value: String);
begin

  // Check for change
  if not(Value = FPipeName) then
  begin
     // Check active state
     if FActive then
        // Cannot change pipe name if pipe server is active
        raise EPipeException.CreateRes(@resPipeActive)
     else
     begin
        // Check the pipe name
        CheckPipeName(Value);
        // Set the new pipe name
        FPipeName:=Value;
     end;
  end;

end;

function TPipeServer.AllocPipeInfo(Pipe: HPIPE): PPipeInfo;
begin

  // Create a new pipe info structure to manage the pipe
  result:=AllocMem(SizeOf(TPipeInfo));

  // Resource protection
  try
     // Set the pipe value
     result^.Pipe:=Pipe;
     // Create the write queue
     result^.WriteQueue:=TWriteQueue.Create;
     // Create individual kill events
     result^.KillEvent:=CreateEvent(nil, True, False, nil);
  finally
     // Add to client list
     FClients.Add(result);
  end;

end;

procedure TPipeServer.AddWorkerThread(Pipe: HPIPE);
var  pstWorker:     TPipeThread;
     ppInfo:        PPipeInfo;
begin

  // Set worker thread
  pstWorker:=nil;

  // Create a new pipe info structure to manage the pipe
  ppInfo:=AllocPipeInfo(Pipe);

  // Resource protection
  try
     // Create the server worker thread
     pstWorker:=TPipeThread.Create(True, FHwnd, FBaseThread, ppInfo^.WriteQueue, FThreadCount, Pipe, ppInfo^.KillEvent);
     // Resource protection
     try
        // Set the OnTerminate handler
        pstWorker.OnTerminate:=RemoveWorkerThread;
     finally
        // Resume the thread
        pstWorker.Resume;
     end;
  except
     // Exception during thread create, remove the client record
     RemoveClient(Pipe);
     // Disconnect and close the pipe handle
     DisconnectAndClose(Pipe);
     // Free the worker thread object
     FreeAndNil(pstWorker);
  end;

end;

procedure TPipeServer.RemoveWorkerThread(Sender: TObject);
begin

  // Remove the pipe info record associated with this thread
  RemoveClient(TPipeThread(Sender).Pipe);

end;

procedure TPipeServer.RemoveListenerThread(Sender: TObject);
begin

  // Nil the thread var
  FListener:=nil;

  // If we are not in a shutdown and are the only thread, then change the active state
  if (not(FInShutDown) and (FThreadCount.Count = 1)) then FActive:=False;

end;

procedure TPipeServer.DoStartup;
begin

  // Check active state
  if not(FActive) then
  begin
     // Make sure the kill event is in a non-signaled state
     ResetEvent(FKillEv);
     // Resource protection
     try
        // Create the listener thread
        FListener:=TPipeListenThread.Create(Self, FKillEv);
        // Resource protection
        try
           // Set the OnTerminate handler
           FListener.OnTerminate:=RemoveListenerThread;
        finally
           // Resume
           FListener.Resume;
        end;
     except
        // Free the listener thread
        FreeAndNil(FListener);
        // Re-raise the exception
        raise;
     end;
     // Set active state
     FActive:=True;
  end;

end;

procedure TPipeServer.DoShutdown;
begin

  // If we are not active then exit
  if FActive and not(FInShutDown) then
  begin
     // Check in message flag
     if InSendMessage then
        // Defered shutdown
        PostMessage(FHwnd, WM_DOSHUTDOWN, 0, 0)
     else
     begin
        // Set shutdown flag
        FInShutDown:=True;
        // Resource protection
        try
           // Resource protection
           try
              // Signal the kill event for the listener thread
              SetEvent(FKillEv);
              // Disconnect all
              Disconnect(0);
              // Wait until threads have finished up
              FThreadCount.WaitForEmpty;
           finally
              // Reset active state
              FActive:=False;
           end;
        finally
           // Set active state to false
           FInShutDown:=False;
        end;
     end;
  end;

end;

//// TPipeThread ///////////////////////////////////////////////////////////////
constructor TPipeThread.Create(Server: Boolean; NotifyWindow: HWND; NotifyThread: THandle; WriteQueue: TWriteQueue; Counter: TThreadCounter; Pipe: HPIPE; KillEvent: THandle);
begin

  // Perform inherited create (suspended)
  inherited Create(True);

  // Increment the thread counter if assigned
  if Assigned(FCounter) then FCounter.Increment;

  // Set initial state
  FServer:=Server;
  FNotify:=NotifyWindow;
  FNotifyThread:=NotifyThread;
  FWriteQueue:=WriteQueue;
  FCounter:=Counter;
  FPipe:=Pipe;
  FErrorCode:=ERROR_SUCCESS;
  FPendingRead:=False;
  FPendingWrite:=False;
  FPipeWrite:=nil;
  FMultiMsg:=nil;
  FRcvSize:=MAX_BUFFER;
  FRcvAlloc:=MAX_BUFFER;
  FRcvBuffer:=AllocMem(FRcvAlloc);
  FRcvStream:=TFastMemStream.Create;
  ClearOverlapped(FOlapRead, True);
  ClearOverlapped(FOlapWrite, True);
  FOlapRead.hEvent:=CreateEvent(nil, True, False, nil);
  FOlapWrite.hEvent:=CreateEvent(nil, True, False, nil);
  ResetEvent(KillEvent);
  FEvents[0]:=KillEvent;
  FEvents[1]:=FOlapRead.hEvent;
  FEvents[2]:=FOlapWrite.hEvent;
  FEvents[3]:=FWriteQueue.DataEvent;

  // Set thread parameters
  FreeOnTerminate:=True;
  Priority:=tpLower;

end;

destructor TPipeThread.Destroy;
begin

  // Resource protection
  try
     // Resource protection
     try
        // Free the write buffer we may be holding on to
        DisposePipeWrite(FPipeWrite);
        // Free the receiver stream
        FRcvStream.Free;
        // Free buffer memory
        FreeMem(FRcvBuffer);
     finally
        // Decrement the thread counter if assigned
        if Assigned(FCounter) then FCounter.Decrement;
     end;
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

function TPipeThread.SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;
begin

  // Check notification window
  if IsWindow(FNotify) then
     // Send the message
     result:=SendMessage(FNotify, Msg, wParam, lParam)
  else
     // Failure
     result:=0;

end;

function TPipeThread.QueuedRead: Boolean;
begin

  // Resource protection
  try
     // If we already have a pending read then nothing to do
     if not(FPendingRead) then
     begin
        // Set buffer size
        FRcvSize:=FRcvAlloc;
        // Keep reading all available data until we get a pending read or a failure
        while not(FPendingRead) do
        begin
           // Set overlapped fields
           ClearOverlapped(FOlapRead);
           // Perform a read
           if ReadFile(FPipe, FRcvBuffer^, FRcvSize, FRcvRead, @FOlapRead) then
           begin
              // Resource protection
              try
                 // We read a full message
                 FRcvStream.Write(FRcvBuffer^, FRcvRead);
                 // Call the OnData
                 DoMessage;
              finally
                 // Reset the read event
                 ResetEvent(FOlapRead.hEvent);
              end;
           end
           else
           begin
              // Get the last error code
              FErrorCode:=GetLastError;
              // Handle cases where message is larger than read buffer used
              if (FErrorCode = ERROR_MORE_DATA) then
              begin
                 // Write the current data
                 FRcvStream.Write(FRcvBuffer^, FRcvSize);
                 // Determine how much we need to expand the buffer to
                 if PeekNamedPipe(FPipe, nil, 0, nil, nil, @FRcvSize) then
                 begin
                    // Determine if required size is larger than allocated size
                    if (FRcvSize > FRcvAlloc) then
                    begin
                       // Realloc buffer
                       ReallocMem(FRcvBuffer, FRcvSize);
                       // Update allocated size
                       FRcvAlloc:=FRcvSize;
                    end;
                 end
                 else
                 begin
                    // Failure
                    FErrorCode:=GetLastError;
                    // Done
                    break;
                 end;
              end
              // Pending read
              else if (FErrorCode = ERROR_IO_PENDING) then
                 // Set pending flag
                 FPendingRead:=True
              else
                 // Failure
                 break;
           end;
        end;
     end;
  finally
     // Success if we have a pending read
     result:=FPendingRead;
  end;

end;

function TPipeThread.CompleteRead: Boolean;
begin

  // Reset the read event and pending flag
  ResetEvent(FOlapRead.hEvent);

  // Reset pending read
  FPendingRead:=False;

  // Check the overlapped results
  result:=GetOverlappedResult(FPipe, FOlapRead, FRcvRead, True);

  // Handle failure
  if not(result) then
  begin
     // Get the last error code
     FErrorCode:=GetLastError;
     // Check for more data
     if (FErrorCode = ERROR_MORE_DATA) then
     begin
        // Write the current data to the stream
        FRcvStream.Write(FRcvBuffer^, FRcvSize);
        // Determine how much we need to expand the buffer to
        result:=PeekNamedPipe(FPipe, nil, 0, nil, nil, @FRcvSize);
        // Check result
        if result then
        begin
           // Determine if required size is larger than allocated size
           if (FRcvSize > FRcvAlloc) then
           begin
              // Realloc buffer
              ReallocMem(FRcvBuffer, FRcvSize);
              // Update allocated size
              FRcvAlloc:=FRcvSize;
           end;
           // Set overlapped fields
           ClearOverlapped(FOlapRead);
           // Read from the file again
           result:=ReadFile(FPipe, FRcvBuffer^, FRcvSize, FRcvRead, @FOlapRead);
           // Handle error
           if not(result) then
           begin
              // Set error code
              FErrorCode:=GetLastError;
              // Check for pending again, which means our state hasn't changed
              if (FErrorCode = ERROR_IO_PENDING) then
              begin
                 // Still a pending read
                 FPendingRead:=True;
                 // Success
                 result:=True;
              end;
           end;
        end
        else
           // Set error code
           FErrorCode:=GetLastError;
     end;
  end;

  // Check result and pending read flag
  if result and not(FPendingRead) then
  begin
     // We have the full message
     FRcvStream.Write(FRcvBuffer^, FRcvRead);
     // Call the OnData
     DoMessage;
  end;

end;

function TPipeThread.QueuedWrite: Boolean;
var  bWrite:        Boolean;
begin

  // Set default result
  result:=True;

  // Check pending state
  if not(FPendingWrite) then
  begin
     // Check state of data event
     if (WaitForSingleObject(FEvents[3], 0) = WAIT_OBJECT_0) then
     begin
        // Dequeue write block
        FPipeWrite:=FWriteQueue.Dequeue;
        // Is the record assigned?
        if Assigned(FPipeWrite) then
        begin
           // Set overlapped fields
           ClearOverlapped(FOlapWrite);
           // Write the data to the client
           bWrite:=WriteFile(FPipe, FPipeWrite^.Buffer^, FPipeWrite^.Count, FWrite, @FOlapWrite);
           // Get the last error code
           FErrorCode:=GetLastError;
           // Check the write operation
           if bWrite then
           begin
              // Resource protection
              try
                 // Flush the pipe
                 FlushFileBuffers(FPipe);
                 // Call the OnData in the main thread
                 SafeSendMessage(WM_PIPESEND, FPipe, FWrite);
                 // Free the pipe write data
                 DisposePipeWrite(FPipeWrite);
              finally
                 // Reset the write event
                 ResetEvent(FOlapWrite.hEvent);
              end;
           end
           // Only acceptable error is pending
           else if (FErrorCode = ERROR_IO_PENDING) then
              // Set pending flag
              FPendingWrite:=True
           else
              // Failure
              result:=False;
        end;
     end
     else
        // No data to write
        result:=True;
  end;

end;

function TPipeThread.CompleteWrite: Boolean;
begin

  // Reset the write event and pending flag
  ResetEvent(FOlapWrite.hEvent);

  // Resource protection
  try
     // Check the overlapped results
     result:=GetOverlappedResult(FPipe, FOlapWrite, FWrite, True);
     // Resource protection
     try
        // Handle failure
        if not(result) then
           // Get the last error code
           FErrorCode:=GetLastError
        else
        begin
           // Flush the pipe
           FlushFileBuffers(FPipe);
           // We sent a full message so call the OnSent in the main thread
           SafeSendMessage(WM_PIPESEND, FPipe, FWrite);
        end;
     finally
        // Make sure to free the queued pipe data
        DisposePipeWrite(FPipeWrite);
     end;
  finally
     // Reset pending flag
     FPendingWrite:=False;
  end;

end;

procedure TPipeThread.DoMessage;
var  lpControlMsg:  PPipeMsgBlock;
begin

  // Rewind the stream
  FRcvStream.Position:=0;

  // Resource protection
  try
     // Check the data to see if this is a multi part message
     if (FRcvStream.Size = SizeOf(TPipeMsgBlock)) then
     begin
        // Cast memory as control message
        lpControlMsg:=PPipeMsgBlock(FRcvStream.Memory);
        // Check constants
        if (lpControlMsg^.Size = SizeOf(TPipeMsgBlock)) and (lpControlMsg^.MagicStart = MB_MAGIC) and (lpControlMsg^.MagicEnd = MB_MAGIC) then
        begin
           // Check to see if this is a start
           if (lpControlMsg^.ControlCode = MB_START) then
           begin
              // Free existing multi part message
              FreeAndNil(FMultiMsg);
              // Create new multi part message
              FMultiMsg:=TPipeMultiMsg.Create;
           end
           // Check to see if this is an end
           else if (lpControlMsg^.ControlCode = MB_END) then
           begin
              // The multi part message must be assigned
              if Assigned(FMultiMsg) then
              begin
                 // Resource protection
                 try
                    // Rewind the stream
                    FMultiMsg.Stream.Position:=0;
                    // Send the message to the notification window
                    SafeSendMessage(WM_PIPEMESSAGE, FPipe, Integer(FMultiMsg.Stream));
                 finally
                    // Free the multi part message
                    FreeAndNil(FMultiMsg);
                 end;
              end;
           end
           else
              // Unknown code
              FreeAndNil(FMultiMsg);
        end
        else
        begin
           // Check for multi part message packet
           if Assigned(FMultiMsg) then
              // Add data to existing stream
              FMultiMsg.Stream.Write(FRcvStream.Memory^, FRcvStream.Size)
           else
              // Send the message to the notification window
              SafeSendMessage(WM_PIPEMESSAGE, FPipe, Integer(FRcvStream));
        end;
     end
     // Check to see if we are in a multi part message
     else if Assigned(FMultiMsg) then
        // Add data to existing stream
        FMultiMsg.Stream.Write(FRcvStream.Memory^, FRcvStream.Size)
     else
        // Send the message to the notification window
        SafeSendMessage(WM_PIPEMESSAGE, FPipe, Integer(FRcvStream));
  finally
     // Clear the read stream
     FRcvStream.Clear;
  end;

end;

procedure TPipeThread.Execute;
var  dwEvents:   Integer;
     bOK:        Boolean;
begin

  // Resource protection
  try
     // Check sync base thread against the component main thread
     if not(Sync.SyncBaseTID = FNotifyThread) then
        // Post message to main window and we are done
        PostMessage(FNotify, WM_THREADCTX, 0, 0)
     else
     begin
        // Notify the pipe server of the connect
        if FServer then SafeSendMessage(WM_PIPECONNECT, FPipe, 0);
        // Loop while not terminated
        while not(Terminated) do
        begin
           // Make sure we always have an outstanding read and write queued up
           bOK:=(QueuedRead and QueuedWrite);
           // Relinquish time slice
           Sleep(0);
           // Check current queue state
           if bOK then
           begin
              // Set number of events to wait on
              dwEvents:=4;
              // If a write is pending, then don't wait on the write queue data event
              if FPendingWrite then Dec(dwEvents);
              // Handle the event that was signalled (or failure)
              case WaitForMultipleObjects(dwEvents, @FEvents, False, INFINITE) of
                 // Killed by pipe server
                 WAIT_OBJECT_0     :
                 begin
                    // Resource protection
                    try
                       // Finish any final read / write (allow them a small delay to finish up)
                       if FPendingWrite and (WaitForSingleObject(FEvents[2], DEF_SLEEP) = WAIT_OBJECT_0) then CompleteWrite;
                       if FPendingRead and (WaitForSingleObject(FEvents[1], DEF_SLEEP) = WAIT_OBJECT_0) then CompleteRead;
                    finally
                       // Terminate the thread
                       Terminate;
                    end;
                 end;
                 // Read completed
                 WAIT_OBJECT_0 + 1 :  bOK:=CompleteRead;
                 // Write completed
                 WAIT_OBJECT_0 + 2 :  bOK:=CompleteWrite;
                 // Data waiting to be sent
                 WAIT_OBJECT_0 + 3 :  ;
              else
                 // General failure
                 FErrorCode:=GetLastError;
                 // Set status
                 bOK:=False;
              end;
           end;
           // Check status
           if not(bOK) then
           begin
              // Call OnError in the main thread if this is not a disconnect. Disconnects
              // have their own event, and are not to be considered an error
              if not(FErrorCode = ERROR_BROKEN_PIPE) then SafeSendMessage(WM_PIPEERROR_W, FPipe, FErrorCode);
              // Terminate the thread
              Terminate;
           end;
        end;
     end;
  finally
     // Disconnect and close the pipe handle at this point
     DisconnectAndClose(FPipe, FServer);
     // Close all open handles that we own
     CloseHandle(FOlapRead.hEvent);
     CloseHandle(FOlapWrite.hEvent);
  end;

end;

//// TPipeListenThread /////////////////////////////////////////////////////////
constructor TPipeListenThread.Create(PipeServer: TPipeServer; KillEvent: THandle);
begin

  // Perform inherited create (suspended)
  inherited Create(True);

  // Increment the thread counter
  FPipeServer := PipeServer;
  FPipeServer.FThreadCount.Increment;

  // Set starting parameters
  FreeOnTerminate:=True;
  Priority:=tpLower;
  FPipeServer:=PipeServer;
  FNotifyThread:=FPipeServer.FBaseThread;
  FPipeName:=PipeServer.PipeName;
  FNotify:=PipeServer.WindowHandle;
  InitializeSecurity(FSA);
  FPipe:=INVALID_HANDLE_VALUE;
  FConnected:=False;
  FillChar(FOlapConnect, SizeOf(FOlapConnect), 0);
  FOlapConnect.hEvent:=CreateEvent(@FSA, True, False, nil);;
  FEvents[0]:=KillEvent;
  FEvents[1]:=FOlapConnect.hEvent;

end;

destructor TPipeListenThread.Destroy;
begin

  // Resource protection
  try
     // Resource protection
     try
        // Close the connect event handle
        CloseHandle(FOlapConnect.hEvent);
        // Disconnect and free the handle
        if IsHandle(FPipe) then
        begin
           // Check connected state
           if FConnected then
              // Disconnect and close
              DisconnectAndClose(FPipe)
           else
              // Just close the handle
              CloseHandle(FPipe);
        end;
        // Release memory for security structure
        FinalizeSecurity(FSA);
     finally
        // Decrement the thread counter
        FPipeServer.FThreadCount.Decrement;
     end;
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

function TPipeListenThread.CreateServerPipe: Boolean;
begin

  // Create the outbound pipe first
  FPipe:=CreateNamedPipe(PChar(resPipeBaseName + FPipeName), PIPE_OPENMODE, PIPE_MODE, PIPE_INSTANCES, 0, 0, 1000, @FSA);

  // Resource protection
  try
     // Set result value based on valid handle
     if IsHandle(FPipe) then
        // Success
        FErrorCode:=ERROR_SUCCESS
     else
        // Get last error
        FErrorCode:=GetLastError;
  finally
     // Success if handle is valid
     result:=IsHandle(FPipe);
  end;

end;

procedure TPipeListenThread.DoWorker;
begin

  // Call the pipe server on the main thread to add a new worker thread
  FPipeServer.AddWorkerThread(FPipe);

end;

function TPipeListenThread.SafeSendMessage(Msg: Cardinal; wParam, lParam: Integer): LRESULT;
begin

  // Check notify window handle
  if IsWindow(FNotify) then
     // Send the message
     result:=SendMessage(FNotify, Msg, wParam, lParam)
  else
     // Not a window
     result:=0;

end;

procedure TPipeListenThread.Execute;
begin

  // Check sync base thread against the component main thread
  if not(Sync.SyncBaseTID = FNotifyThread) then
     // Post message to main window and we are done
     PostMessage(FNotify, WM_THREADCTX, 0, 0)
  else
  begin
     // Thread body
     while not(Terminated) do
     begin
        // Set default state
        FConnected:=False;
        // Attempt to create first pipe server instance
        if CreateServerPipe then
        begin
           // Connect the named pipe
           FConnected:=ConnectNamedPipe(FPipe, @FOlapConnect);
           // Handle failure
           if not(FConnected) then
           begin
              // Check the last error code
              FErrorCode:=GetLastError;
              // Is pipe connected?
              if (FErrorCode = ERROR_PIPE_CONNECTED) then
                 // Set connected state
                 FConnected:=True
              // IO pending?
              else if(FErrorCode = ERROR_IO_PENDING) then
              begin
                 // Wait for a connect or kill signal
                 case WaitForMultipleObjects(2, @FEvents, False, INFINITE) of
                    WAIT_FAILED       :  FErrorCode:=GetLastError;
                    WAIT_OBJECT_0     :  Terminate;
                    WAIT_OBJECT_0 + 1 :  FConnected:=True;
                 end;
              end;
           end;
        end;
        // If we are not connected at this point then we had a failure
        if not(FConnected) then
        begin
           // Resource protection
           try
              // No error if terminated or client connects / disconnects (no data)
              if not(Terminated or (FErrorCode = ERROR_NO_DATA)) then SafeSendMessage(WM_PIPEERROR_L, FPipe, FErrorCode);
           finally
              // Close and clear
              CloseHandleClear(FPipe);
           end;
        end
        else
           // Notify server of connect
           Synchronize(DoWorker);
     end;
  end;

end;

//// TThreadCounter ////////////////////////////////////////////////////////////
constructor TThreadCounter.Create;
begin

  // Perform inherited
  inherited Create;

  // Create critical section lock
  InitializeCriticalSection(FLock);

  // Create event for empty state
  FEmpty:=CreateEvent(nil, True, True, nil);

  // Set the starting count
  FCount:=0;

end;

destructor TThreadCounter.Destroy;
begin

  // Resource protection
  try
     // Close the event handle
     CloseHandleClear(FEmpty);
     // Delete the critical section
     DeleteCriticalSection(FLock);
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

function TThreadCounter.GetCount: Integer;
begin

  // Enter critical section
  EnterCriticalSection(FLock);

  // Resource protection
  try
     // Return the count
     result:=FCount;
  finally
     // Leave the critical section
     LeaveCriticalSection(FLock);
  end;

end;

procedure TThreadCounter.Increment;
begin

  // Enter critical section
  EnterCriticalSection(FLock);

  // Resource protection
  try
     // Increment the count
     Inc(FCount);
     // Reset the empty event
     ResetEvent(FEmpty);
  finally
     // Leave the critical section
     LeaveCriticalSection(FLock);
  end;

end;

procedure TThreadCounter.Decrement;
begin

  // Enter critical section
  EnterCriticalSection(FLock);

  // Resource protection
  try
     // Decrement the count
     if (FCount > 0) then Dec(FCount);
     // Signal empty event if count is zero
     if (FCount = 0) then SetEvent(FEmpty);
  finally
     // Leave the critical section
     LeaveCriticalSection(FLock);
  end;

end;

procedure TThreadCounter.WaitForEmpty;
begin

  // Wait until the empty event is signalled
  while (MsgWaitForMultipleObjects(1, FEmpty, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1) do
  begin
     // Messages waiting to be read
     FlushMessages;
  end;

end;

//// TWriteQueue ///////////////////////////////////////////////////////////////
constructor TWriteQueue.Create;
begin

  // Perform inherited
  inherited Create;

  // Set defaults
  FHead:=nil;
  FTail:=nil;
  FMutex:=0;
  FDataEv:=0;
  FDataSize:=0;
  FEmptyEv:=0;

  // Create mutex to allow for single access into the write queue
  FMutex:=CreateMutex(nil, False, nil);

  // Check mutex handle
  if (FMutex = 0) then
     // Raise exception
     RaiseWindowsError
  else
  begin
     // Create event to signal when we have data to write
     FDataEv:=CreateEvent(nil, True, False, nil);
     // Check event handle
     if (FDataEv = 0) then
        // Raise exception
        RaiseWindowsError
     else
     begin
        // Create event to signal when the queue becomes empty
        FEmptyEv:=CreateEvent(nil, True, True, nil);
        // Check event handle, raise exception on failure
        if (FEmptyEv = 0) then RaiseWindowsError;
     end;
  end;

end;

destructor TWriteQueue.Destroy;
begin

  // Resource protection
  try
     // Clear
     Clear;
     // Close the data event handle
     CloseHandleClear(FDataEv);
     // Close the empty event handle
     CloseHandleClear(FEmptyEv);
     // Close the mutex handle
     CloseHandleClear(FMutex);
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

function TWriteQueue.GetEmpty: Boolean;
begin

  // Determine if queue is empty
  result:=(FHead = nil);

end;

procedure TWriteQueue.Clear;
var  lpNode:        PWriteNode;
begin

  // Access the mutex
  WaitForSingleObject(FMutex, INFINITE);

  // Resource protection
  try
     // Reset the writer event
     ResetEvent(FDataEv);
     // Resource protection
     try
        // Resource protection
        try
           // Free all the items in the stack
           while Assigned(FHead) do
           begin
              // Get the head node and push forward
              lpNode:=FHead;
              // Resource protection
              try
                 // Update head
                 FHead:=lpNode^.NextNode;
                 // Free the pipe write data
                 DisposePipeWrite(lpNode^.PipeWrite);
              finally
                 // Free the queued node
                 FreeMem(lpNode);
              end;
           end;
        finally
           // Clear the tail
           FTail:=nil;
           // Reset the data size
           FDataSize:=0;
        end;
     finally
        // Signal the empty event
        SetEvent(FEmptyEv);
     end;
  finally
     // Release the mutex
     ReleaseMutex(FMutex);
  end;

end;

function TWriteQueue.NodeSize(Node: PWriteNode): LongWord;
begin

  // Result is at least size of TWriteNode plus allocator size
  result:=SizeOf(TWriteNode) + SizeOf(Integer);

  // Check pipe write
  if Assigned(Node^.PipeWrite) then
  begin
     // Include the pipe write structure
     Inc(result, SizeOf(TPipeWrite) + SizeOf(Integer));
     // Include the pipe write data count
     Inc(result, Node^.PipeWrite^.Count + SizeOf(Integer));
  end;

end;

function TWriteQueue.NewNode(PipeWrite: PPipeWrite): PWriteNode;
begin

  // Allocate memory for new node
  GetMem(result, SizeOf(TWriteNode));

  // Resource protection
  try
     // Set the pipe write field
     result^.PipeWrite:=PipeWrite;
     // Update the data count
     Inc(FDataSize, NodeSize(result));
  finally
     // Make sure the next link is nil
     result^.NextNode:=nil;
  end;

end;

procedure TWriteQueue.EnqueueControlPacket(ControlCode: DWORD);
var  lpControlMsg:  TPipeMsgBlock;
begin

  // Access the mutex
  WaitForSingleObject(FMutex, INFINITE);

  // Resource protection
  try
     // Set control message constants
     lpControlMsg.Size:=SizeOf(TPipeMsgBlock);
     lpControlMsg.MagicStart:=MB_MAGIC;
     lpControlMsg.MagicEnd:=MB_MAGIC;
     // Set end control message
     lpControlMsg.ControlCode:=ControlCode;
     // Create pipe write and queue the data
     Enqueue(AllocPipeWrite(lpControlMsg, SizeOf(TPipeMsgBlock)));
  finally
     // Release the mutex
     ReleaseMutex(FMutex);
  end;

end;

procedure TWriteQueue.EnqueueEndPacket;
begin

  // Enqueue the start
  EnqueueControlPacket(MB_END);

end;

procedure TWriteQueue.EnqueueStartPacket;
begin

  // Enqueue the start
  EnqueueControlPacket(MB_START);

end;

procedure TWriteQueue.EnqueueMultiPacket(PipeWrite: PPipeWrite);
var  lpData:        PChar;
     dwSize:        Integer;
begin

  // Access the mutex
  WaitForSingleObject(FMutex, INFINITE);

  // Resource protection
  try
     // Resource protection
     try
        // Resource protection
        try
           // Enqueue the start packet
           EnqueueStartPacket;
           // Get pointer to pipe write data
           lpData:=PipeWrite^.Buffer;
           // While count of data to move
           while (PipeWrite^.Count > 0) do
           begin
              // Determine packet size
              if (PipeWrite^.Count > MAX_BUFFER) then
                 // Full packet size
                 dwSize:=MAX_BUFFER
              else
                 // Final packet
                 dwSize:=PipeWrite^.Count;
              // Resource protection
              try
                 // Create pipe write and queue the data
                 Enqueue(AllocPipeWrite(lpData^, dwSize));
                 // Increment the data pointer
                 Inc(lpData, dwSize);
              finally
                 // Decrement the remaining count
                 Dec(PipeWrite^.Count, dwSize);
              end;
           end;
        finally
           // Enqueue the end packet
           EnqueueEndPacket;
        end;
     finally
        // Dispose of the original pipe write
        DisposePipeWrite(PipeWrite);
     end;
  finally
     // Release the mutex
     ReleaseMutex(FMutex);
  end;

end;

procedure TWriteQueue.UpdateState;
begin

  // Check head node
  if Assigned(FHead) then
  begin
     // Signal data event
     SetEvent(FDataEv);
     // Reset empty event
     ResetEvent(FEmptyEv);
  end
  else
  begin
     // Reset data event
     ResetEvent(FDataEv);
     // Signal empty event
     SetEvent(FEmptyEv);
  end;

end;

procedure TWriteQueue.Enqueue(PipeWrite: PPipeWrite);
var  lpNode:        PWriteNode;
begin

  // Access the mutex
  WaitForSingleObject(FMutex, INFINITE);

  // Resource protection
  try
     // Check pipe write
     if Assigned(PipeWrite) then
     begin
        // Resource protection
        try
           // Check count of bytes in the pipe write record
           if (PipeWrite^.Count > MAX_BUFFER) then
              // Need to create multi packet message
              EnqueueMultipacket(PipeWrite)
           else
           begin
              // Create a new node
              lpNode:=NewNode(PipeWrite);
              // Resource protection
              try
                 // Make this the last item in the queue
                 if Assigned(FTail) then
                    // Update the next node
                    FTail^.NextNode:=lpNode
                 else
                    // Set the head node
                    FHead:=lpNode;
              finally
                 // Update the new tail
                 FTail:=lpNode;
              end;
           end;
        finally
           // Update event state
           UpdateState;
        end;
     end;
  finally
     // Release the mutex
     ReleaseMutex(FMutex);
  end;

end;

function TWriteQueue.Dequeue: PPipeWrite;
var  lpNode:        PWriteNode;
begin

  // Access the mutex
  WaitForSingleObject(FMutex, INFINITE);

  // Resource protection
  try
     // Resource protection
     try
        // Remove the first item from the queue
        if Assigned(FHead) then
        begin
           // Get head node
           lpNode:=FHead;
           // Update the data count
           Dec(FDataSize, NodeSize(lpNode));
           // Resource protection
           try
              // Set the return data
              result:=lpNode^.PipeWrite;
              // Does head = Tail?
              if (FHead = FTail) then FTail:=nil;
              // Update the head
              FHead:=lpNode^.NextNode;
           finally
              // Free the memory for the node
              FreeMem(lpNode);
           end;
        end
        else
           // No queued data
           result:=nil;
     finally
        // Update state
        UpdateState;
     end;
  finally
     // Release the mutex
     ReleaseMutex(FMutex);
  end;

end;

//// TPipeMultiMsg /////////////////////////////////////////////////////////////
procedure TPipeMultiMsg.CreateTempBacking;
var  lpszPath:      Array [0..MAX_PATH] of Char;
     lpszFile:      Array [0..MAX_PATH] of Char;
begin

  // Resource protection
  try
     // Attempt to get temp file
     if (GetTempPath(MAX_PATH, lpszPath) > 0) and (GetTempFileName(@lpszPath, MB_PREFIX, 0, @lpszFile) > 0) then
        // Open the temp file
        FHandle:=CreateFile(@lpszFile, GENERIC_READ or GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, 0)
     else
        // Failed to get temp filename
        FHandle:=INVALID_HANDLE_VALUE;
  finally
     // If we failed to open a temp file then we will use memory for data backing
     if IsHandle(FHandle) then
        // Create handle stream
        FStream:=THandleStream.Create(FHandle)
     else
        // Create fast memory stream
        FStream:=TFastMemStream.Create;
  end;

end;

constructor TPipeMultiMsg.Create;
begin

  // Perform inherited
  inherited Create;

  // Create temp file backing
  CreateTempBacking;

end;

destructor TPipeMultiMsg.Destroy;
begin

  // Resource protection
  try
     // Free the stream
     FreeAndNil(FStream);
     // Close handle if open
     if IsHandle(FHandle) then CloseHandle(FHandle);
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

//// TFastMemStream ////////////////////////////////////////////////////////////
function TFastMemStream.Realloc(var NewCapacity: Longint): Pointer;
var  dwDelta:       Integer;
     lpMemory:      Pointer;
begin

  // Get current memory pointer
  lpMemory:=Memory;

  // Resource protection
  try
     // Calculate the delta to be applied to the capacity
     if (NewCapacity > 0) then
     begin
        // Check new capacity
        if (NewCapacity > MaxWord) then
           // Delta is 1/4 of desired capacity
           dwDelta:=NewCapacity div 4
        else
           // Minimum allocation of 64 KB
           dwDelta:=MaxWord;
        // Update by delta
        Inc(NewCapacity, dwDelta);
     end;
     // Determine if capacity has changed
     if not(NewCapacity = Capacity) then
     begin
        // Check for nil alloc
        if (NewCapacity = 0) then
        begin
           // Release the memory
           FreeMem(lpMemory);
           // Clear result
           lpMemory:=nil;
        end
        else
        begin
           // Check current capacity
           if (Capacity = 0) then
              // Allocate memory
              lpMemory:=AllocMem(NewCapacity)
           else
              // Reallocate memory
              ReallocMem(lpMemory, NewCapacity);
        end;
     end;
  finally
     // Return modified pointer
     result:=lpMemory;
  end;

end;

//// Thread window procedure ///////////////////////////////////////////////////
function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall;
begin

  // Handle the window message
  case Message of
     // Exceute the method in thread
     CM_EXECPROC       :
     begin
        // The lParam constains the thread sync information
        with TThreadSync(lParam) do
        begin
           // Set message result
           result:=0;
           // Exception trap
           try
              // Clear the exception
              FSyncRaise:=nil;
              // Call the method
              FMethod;
           except
              {$IFNDEF DELPHI_6_ABOVE}
              if not(RaiseList = nil) then
              begin
                 // Get exception object from frame
                 FSyncRaise:=PRaiseFrame(RaiseList)^.ExceptObject;
                 // Clear frame exception object
                 PRaiseFrame(RaiseList)^.ExceptObject:=nil;
              end;
              {$ELSE}
              FSyncRaise:=AcquireExceptionObject;
              {$ENDIF}
           end;
        end;
     end;
     // Thead destroying
     CM_DESTROYWINDOW  :
     begin
        // Get instance of sync manager
        TSyncManager.Instance.DoDestroyWindow(TSyncInfo(lParam));
        // Set message result
        result:=0;
     end;
  else
     // Call the default window procedure
     result:=DefWindowProc(Window, Message, wParam, lParam);
  end;

end;

//// TSyncManager //////////////////////////////////////////////////////////////
constructor TSyncManager.Create;
begin

  // Perform inherited
  inherited Create;

  // Initialize the critical section
  InitializeCriticalSection(FThreadLock);

  // Create the info list
  FList:=TList.Create;

end;

destructor TSyncManager.Destroy;
var  dwIndex:       Integer;
begin

  // Resource protection
  try
     // Free all info records
     for dwIndex:=Pred(FList.Count) downto 0 do FreeSyncInfo(TSyncInfo(FList[dwIndex]));
     // Free the list
     FList.Free;
     // Delete the critical section
     DeleteCriticalSection(FThreadLock);
  finally
     // Call inherited
     inherited Destroy;
  end;

end;

class function TSyncManager.Instance: TSyncManager;
begin

  // Enter critical section
  EnterCriticalSection(InstCritSect);

  // Resource protection
  try
     // Check global instance, create if needed
     if (SyncManager = nil) then SyncManager:=TSyncManager.Create;
     // Return instance of sync manager
     result:=SyncManager
  finally
     // Leave critical section
     LeaveCriticalSection(InstCritSect);
  end;

end;

function TSyncManager.AllocateWindow: HWND;
var  clsTemp:       TWndClass;
     bClassReg:     Boolean;
begin

  // Set instance handle
  ThreadWndClass.hInstance:=HInstance;
  ThreadWndClass.lpfnWndProc:=@ThreadWndProc;

  // Attempt to get class info
  bClassReg:=GetClassInfo(HInstance, ThreadWndClass.lpszClassName, clsTemp);

  // Ensure the class is registered and the window procedure is the default window proc
  if not(bClassReg) or not(clsTemp.lpfnWndProc = @ThreadWndProc) then
  begin
     // Unregister if already registered
     if bClassReg then Windows.UnregisterClass(ThreadWndClass.lpszClassName, HInstance);
     // Register
     Windows.RegisterClass(ThreadWndClass);
  end;

  // Create the thread window
  result:=CreateWindowEx(0, ThreadWndClass.lpszClassName, '', 0, 0, 0, 0, 0, 0, 0, HInstance, nil);

end;

procedure TSyncManager.AddThread(ThreadSync: TThreadSync);
var  lpInfo:        TSyncInfo;
begin

  // Enter critical section
  EnterCriticalSection(FThreadLock);

  // Resource protection
  try
     // Find the info using the base thread id
     lpInfo:=FindSyncInfo(ThreadSync.SyncBaseTID);
     // Resource protection
     try
        // Check assignment
        if (lpInfo = nil) then
        begin
           // Create new info record
           lpInfo:=TSyncInfo.Create;
           // Set base thread id
           lpInfo.FSyncBaseTID:=ThreadSync.SyncBaseTID;
           // Add info to list
           FList.Add(lpInfo);
        end;
        // Check thread count, create window if needed
        if (lpInfo.FThreadCount = 0) then lpInfo.FThreadWindow:=AllocateWindow;
     finally
        // Increment the thread count
        Inc(lpInfo.FThreadCount);
     end;
  finally
     // Leave the critical section
     LeaveCriticalSection(FThreadLock);
  end;

end;

procedure TSyncManager.RemoveThread(ThreadSync: TThreadSync);
var  lpInfo:        TSyncInfo;
begin

  // Enter critical section
  EnterCriticalSection(FThreadLock);

  // Resource protection
  try
     // Find the info using the base thread id
     lpInfo:=FindSyncInfo(ThreadSync.SyncBaseTID);
     // Check assignment
     if Assigned(lpInfo) then PostMessage(lpInfo.FThreadWindow, CM_DESTROYWINDOW, 0, Longint(lpInfo));
  finally
     // Leave the critical section
     LeaveCriticalSection(FThreadLock);
  end;

end;

procedure TSyncManager.DoDestroyWindow(Info: TSyncInfo);
begin

  // Enter critical section
  EnterCriticalSection(FThreadLock);

  // Resource protection
  try
     // Decrement the thread count
     Dec(Info.FThreadCount);
     // Check for zero threads
     if (Info.FThreadCount = 0) then FreeSyncInfo(Info);
  finally
     // Leave the critical section
     LeaveCriticalSection(FThreadLock);
  end;

end;

procedure TSyncManager.FreeSyncInfo(Info: TSyncInfo);
begin

  // Check thread window
  if not(Info.FThreadWindow = 0) then
  begin
     // Resource protection
     try
        // Destroy window
        DestroyWindow(Info.FThreadWindow);
        // Remove from list
        FList.Remove(Info);
     finally
        // Free the class structure
        Info.Free;
     end;
  end;

end;

procedure TSyncManager.Synchronize(ThreadSync: TThreadSync);
var  lpInfo:        TSyncInfo;
begin

  // Find the info using the base thread id
  lpInfo:=FindSyncInfo(ThreadSync.SyncBaseTID);

  // Check assignment, send message to thread window
  if Assigned(lpInfo) then SendMessage(lpInfo.FThreadWindow, CM_EXECPROC, 0, Longint(ThreadSync));

end;

function TSyncManager.FindSyncInfo(SyncBaseTID: LongWord): TSyncInfo;
var  dwIndex:       Integer;
begin

  // Set default result
  result:=nil;

  // Locate in list
  for dwIndex:=0 to Pred(FList.Count) do
  begin
     // Compare thread id's
     if (TSyncInfo(FList[dwIndex]).FSyncBaseTID = SyncBaseTID) then
     begin
        // Found the info structure
        result:=TSyncInfo(FList[dwIndex]);
        // Done processing
        break;
     end;
  end;

end;

//// TThreadSync ///////////////////////////////////////////////////////////////
constructor TThreadSync.Create;
begin

  // Perform inherited
  inherited Create;

  // Set the base thread id
  FSyncBaseTID:=GetCurrentThreadId;

  // Add self to sync manager
  TSyncManager.Instance.AddThread(Self);

end;

destructor TThreadSync.Destroy;
begin

  // Resource protection
  try
     // Remove self from sync manager
     TSyncManager.Instance.RemoveThread(Self);
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

procedure TThreadSync.Synchronize(Method: TThreadMethod);
begin

  // Clear sync raise exception object
  FSyncRaise:=nil;

  // Set the method pointer
  FMethod:=Method;

  // Resource protection
  try
     // Have the sync manager call the method
     TSyncManager.Instance.Synchronize(Self);
  finally
     // Check to see if the exception object was set
     if Assigned(FSyncRaise) then raise FSyncRaise;
  end;

end;

//// TThreadEx /////////////////////////////////////////////////////////////////
constructor TThreadEx.Create(CreateSuspended: Boolean);
begin

  // Create the sync
  FSync:=TThreadSync.Create;

  // Perform inherited
  inherited Create(CreateSuspended);

end;

destructor TThreadEx.Destroy;
begin

  // Resource protection
  try
     // Free the sync object
     FSync.Free;
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

procedure TThreadEx.DoTerminate;
begin

  // Overide the DoTerminate and don't call inherited
  if Assigned(OnTerminate) then Sync.Synchronize(HandleTerminate);

end;

procedure TThreadEx.HandleTerminate;
begin

  // Call OnTerminate if assigned
  if Assigned(OnTerminate) then OnTerminate(Self);

end;

procedure TThreadEx.Synchronize(Method: TThreadMethod);
begin

  // Call the sync's version of synchronize
  Sync.Synchronize(Method);

end;

procedure TThreadEx.SafeSynchronize(Method: TThreadMethod);
begin

  // Exception trap
  try
     // Call synchronize
     Sync.Synchronize(Method);
  except
     // Eat the actual exception, just call terminate on the thread
     Terminate;
  end;

end;

procedure TThreadEx.Wait;
var  hThread:       THandle;
     dwExit:        DWORD;
begin

  // Set the thread handle
  hThread:=Handle;

  // Check current thread against the sync thread id
  if (GetCurrentThreadID = Sync.SyncBaseTID) then
  begin
     // Message wait
     while (MsgWaitForMultipleObjects(1, hThread, False, INFINITE, QS_ALLINPUT) = WAIT_OBJECT_0 + 1) do
     begin
        // Flush the messages
        FlushMessages;
        // Check thread state (because the handle is not duplicated, it can become invalid. Testing
        // WaitForSingleObject(Handle, 0) even returns WAIT_TIMEOUT for the invalid handle)
        if not(GetExitCodeThread(hThread, dwExit)) or not(dwExit = STILL_ACTIVE) then break;
     end;
  end
  else
     // Wait is not being called from base thread id, so use WaitForSingleObject
     WaitForSingleObject(hThread, INFINITE);

end;

//// Console helper functions //////////////////////////////////////////////////
type
  TConsoleEvent     =  function(dwCtrlEvent: DWORD; dwProcessGroupId: DWORD): BOOL; stdcall;
  TConsoleHwnd      =  function(): HWND; stdcall;

function ConsoleWindow(ConsoleHwnd: TConsoleHwnd): HWND; stdcall;
begin

  // Check function pointer
  if Assigned(@ConsoleHwnd) then
     // Call function
     result:=ConsoleHwnd()
  else
     // Return zero
     result:=0;

end;

function GetConsoleWindow(ProcessHandle: THandle): HWND;
var  lpConsoleHwnd: Pointer;
     hThread:       THandle;
     dwSize:        DWORD;
     dwWrite:       DWORD;
     dwExit:        DWORD;
begin

  // Get size of function that we need to inject
  dwSize:=PChar(@GetConsoleWindow) - PChar(@ConsoleWindow);

  // Allocate memory in remote process
  lpConsoleHwnd:=VirtualAllocEx(ProcessHandle, nil, dwSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);

  // Check memory, write code from this process
  if Assigned(lpConsoleHwnd) then
  begin
     // Write memory
     WriteProcessMemory(ProcessHandle, lpConsoleHwnd, @ConsoleWindow, dwSize, dwWrite);
     // Resource protection
     try
        // Create remote thread starting at the injected function, passing in the address to GetConsoleWindow
        hThread:=CreateRemoteThread(ProcessHandle, nil, 0, lpConsoleHwnd, GetProcAddress(GetModuleHandle(kernel32), 'GetConsoleWindow'), 0, DWORD(Pointer(nil)^));
        // Check thread
        if (hThread = 0) then
           // Failed to create thread
           result:=0
        else
        begin
           // Resource protection
           try
              // Wait for the thread to complete
              WaitForSingleObject(hThread, INFINITE);
              // Get the exit code from the thread
              if GetExitCodeThread(hThread, dwExit) then
                 // Set return
                 result:=dwExit
              else
                 // Failed to get exit code
                 result:=0;
           finally
              // Close the thread handle
              CloseHandle(hThread);
           end;
        end;
     finally
        // Free allocated memory
        VirtualFreeEx(ProcessHandle, lpConsoleHwnd, 0, MEM_RELEASE);
     end;
  end
  else
     // Failed to create remote injected function
     result:=0;

end;

function GetConsoleWindowEx(ProcessHandle: THandle; ProcessID, ThreadID: DWORD): HWND;
var  lpConInfo:     TPipeConsoleInfo;
begin

  // Call the optimal routine first
  result:=GetConsoleWindow(ProcessHandle);

  // Check return handle
  if (result = 0) then
  begin
     // Clear the window handle
     lpConInfo.Window:=0;
     // Resource protection
     try
        // Set process info
        lpConInfo.ProcessID:=ProcessID;
        lpConInfo.ThreadID:=ThreadID;
        // Enumerate the windows on the console thread
        EnumWindows(@EnumConsoleWindows, Integer(@lpConInfo));
     finally
        // Return the window handle
        result:=lpConInfo.Window;
     end;
  end;

end;

function CtrlBreak(ConsoleEvent: TConsoleEvent): DWORD; stdcall;
begin

  // Generate the control break
  result:=DWORD(ConsoleEvent(CTRL_BREAK_EVENT, 0));

end;
 
function CtrlC(ConsoleEvent: TConsoleEvent): DWORD; stdcall;
begin
 
  // Generate the control break
  result:=DWORD(ConsoleEvent(CTRL_C_EVENT, 0));
 
end;

function ExecConsoleEvent(ProcessHandle: THandle; Event: DWORD): Boolean;
var  lpCtrlEvent:   Pointer;
     hThread:       THandle;
     dwSize:        DWORD;
     dwWrite:       DWORD;
     dwExit:        DWORD;
begin

  // Check event
  case Event of
     // Control C
     CTRL_C_EVENT      :
     begin
        // Get size of function that we need to inject
        dwSize:=PChar(@ExecConsoleEvent) - PChar(@CtrlC);
        // Allocate memory in remote process
        lpCtrlEvent:=VirtualAllocEx(ProcessHandle, nil, dwSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
        // Check memory, write code from this process
        if Assigned(lpCtrlEvent) then WriteProcessMemory(ProcessHandle, lpCtrlEvent, @CtrlC, dwSize, dwWrite);
     end;
     // Control break
     CTRL_BREAK_EVENT  :
     begin
        // Get size of function that we need to inject
        dwSize:=PChar(@CtrlC) - PChar(@CtrlBreak);
        // Allocate memory in remote process
        lpCtrlEvent:=VirtualAllocEx(ProcessHandle, nil, dwSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
        // Check memory, write code from this process
        if Assigned(lpCtrlEvent) then WriteProcessMemory(ProcessHandle, lpCtrlEvent, @CtrlBreak, dwSize, dwWrite);
     end;
  else
     // Not going to handle
     lpCtrlEvent:=nil;
  end;

  // Check remote function address
  if Assigned(lpCtrlEvent) then
  begin
     // Resource protection
     try
        // Create remote thread starting at the injected function, passing in the address to GenerateConsoleCtrlEvent
        hThread:=CreateRemoteThread(ProcessHandle, nil, 0, lpCtrlEvent, GetProcAddress(GetModuleHandle(kernel32), 'GenerateConsoleCtrlEvent'), 0, DWORD(Pointer(nil)^));
        // Check thread
        if (hThread = 0) then
           // Failed to create thread
           result:=False
        else
        begin
           // Resource protection
           try
              // Wait for the thread to complete
              WaitForSingleObject(hThread, INFINITE);
              // Get the exit code from the thread
              if GetExitCodeThread(hThread, dwExit) then
                 // Set return
                 result:=not(dwExit = 0)
              else
                 // Failed to get exit code
                 result:=False;
           finally
              // Close the thread handle
              CloseHandle(hThread);
           end;
        end;
     finally
        // Free allocated memory
        VirtualFreeEx(ProcessHandle, lpCtrlEvent, 0, MEM_RELEASE);
     end;
  end
  else
     // Failed to create remote injected function
     result:=False;

end;

procedure ExitProcessEx(ProcessHandle: THandle; ExitCode: DWORD);
var  hKernel:       HMODULE;
     hThread:       THandle;
begin

  // Get handle to kernel32
  hKernel:=GetModuleHandle(kernel32);

  // Check handle
  if not(hKernel = 0) then
  begin
     // Create a remote thread in the external process and have it call ExitProcess (tricky)
     hThread:=CreateRemoteThread(ProcessHandle, nil, 0, GetProcAddress(hKernel, 'ExitProcess'), Pointer(ExitCode), 0, DWORD(Pointer(nil)^));
     // Check the thread handle
     if (hThread = 0) then
        // Just terminate the process
        TerminateProcess(ProcessHandle, ExitCode)
     else
     begin
        // Resource protection
        try
           // Wait for the thread to complete
           WaitForSingleObject(hThread, INFINITE);
        finally
           // Close the handle
           CloseHandle(hThread);
        end;
     end;
  end
  else
     // Attempt to use the process handle from the create process call
     TerminateProcess(ProcessHandle, ExitCode);

end;

//// Pipe helper functions /////////////////////////////////////////////////////
procedure ClearOverlapped(var Overlapped: TOverlapped; ClearEvent: Boolean = False);
begin

  // Check to see if all fields should be clered
  if ClearEvent then
     // Clear whole structure
     FillChar(Overlapped, SizeOf(Overlapped), 0)
  else
  begin
     // Clear all fields except for the event handle
     Overlapped.Internal:=0;
     Overlapped.InternalHigh:=0;
     Overlapped.Offset:=0;
     Overlapped.OffsetHigh:=0;
  end;

end;

procedure CloseHandleClear(var Handle: THandle);
begin

  // Resource protection
  try
     // Check for invalid handle or zero
     if IsHandle(Handle) then CloseHandle(Handle);
  finally
     // Set to invalid handle
     Handle:=INVALID_HANDLE_VALUE;
  end;

end;

procedure DisconnectAndClose(Pipe: HPIPE; IsServer: Boolean = True);
begin

  // Check handle
  if IsHandle(Pipe) then
  begin
     // Resource protection
     try
        // Cancel overlapped IO on the handle
        CancelIO(Pipe);
        // Flush file buffer
        FlushFileBuffers(Pipe);
        // Disconnect the server end of the named pipe if flag is set
        if IsServer then DisconnectNamedPipe(Pipe);
     finally
        // Close the pipe handle
        CloseHandle(Pipe);
     end;
  end;

end;

procedure RaiseWindowsError;
begin

  {$IFDEF DELPHI_6_ABOVE}
  RaiseLastOSError;
  {$ELSE}
  RaiseLastWin32Error;
  {$ENDIF}

end;

procedure FlushMessages;
var  lpMsg:         TMsg;
begin

  // Flush the message queue for the calling thread
  while PeekMessage(lpMsg, 0, 0, 0, PM_REMOVE) do
  begin
     // Translate the message
     TranslateMessage(lpMsg);
     // Dispatch the message
     DispatchMessage(lpMsg);
     // Allow other threads to run
     Sleep(0);
  end;

end;

function IsHandle(Handle: THandle): Boolean;
begin

  // Determine if a valid handle (only by value)
  result:=not((Handle = 0) or (Handle = INVALID_HANDLE_VALUE));

end;

function ComputerName: String;
var  dwSize:        DWORD;
begin

  // Set max size
  dwSize:=Succ(MAX_PATH);

  // Resource protection
  try
     // Set string length
     SetLength(result, dwSize);
     // Attempt to get the computer name
     if not(GetComputerName(@result[1], dwSize)) then dwSize:=0;
  finally
     // Truncate string
     SetLength(result, dwSize);
  end;

end;

function AllocPipeWriteWithPrefix(const Prefix; PrefixCount: Integer; const Buffer; Count: Integer): PPipeWrite;
var  lpBuffer:      PChar;
begin

  // Allocate memory for the result
  result:=AllocMem(SizeOf(TPipeWrite));

  // Set the count of the buffer
  result^.Count:=PrefixCount + Count;

  // Allocate enough memory to store the prefix and data buffer
  result^.Buffer:=AllocMem(result^.Count);

  // Set buffer pointer
  lpBuffer:=result^.Buffer;

  // Resource protection
  try
     // Move the prefix data in
     System.Move(Prefix, lpBuffer^, PrefixCount);
     // Increment the buffer position
     Inc(lpBuffer, PrefixCount);
  finally
     // Move the buffer data in
     System.Move(Buffer, lpBuffer^, Count);
  end;

end;

function AllocPipeWrite(const Buffer; Count: Integer): PPipeWrite;
begin

  // Allocate memory for the result
  result:=AllocMem(SizeOf(TPipeWrite));

  // Resource protection
  try
     // Set the count of the buffer
     result^.Count:=Count;
     // Allocate enough memory to store the data buffer
     result^.Buffer:=AllocMem(Count);
  finally
     // Move data to the buffer
     System.Move(Buffer, result^.Buffer^, Count);
  end;

end;

procedure DisposePipeWrite(var PipeWrite: PPipeWrite);
begin

  // Check pointer
  if Assigned(PipeWrite) then
  begin
     // Resource protection
     try
        // Resource protection
        try
           // Dispose of the memory being used by the pipe write structure
           if Assigned(PipeWrite^.Buffer) then FreeMem(PipeWrite^.Buffer);
        finally
           // Free the memory record
           FreeMem(PipeWrite);
        end;
     finally
        // Clear the pointer
        PipeWrite:=nil;
     end;
  end;

end;

function EnumConsoleWindows(Window: HWND; lParam: Integer): BOOL; stdcall;
var  lpConInfo:        PPipeConsoleInfo;
begin

  // Get the console info
  lpConInfo:=Pointer(lParam);

  // Get the thread id and compare against the passed structure
  if (lpConInfo^.ThreadID = GetWindowThreadProcessId(Window, nil)) then
  begin
     // Found the window, return the handle
     lpConInfo^.Window:=Window;
     // Stop enumeration
     result:=False;
  end
  else
     // Keep enumerating
     result:=True;

end;

procedure CheckPipeName(Value: String);
begin

  // Validate the pipe name
  if (Pos('\', Value) > 0) or (Length(Value) > MAX_NAME) or (Length(Value) = 0) then raise EPipeException.CreateRes(@resBadPipeName);

end;

//// Security helper functions /////////////////////////////////////////////////
procedure InitializeSecurity(var SA: TSecurityAttributes);
var  sd:            PSecurityDescriptor;
begin

  // Allocate memory for the security descriptor
  sd:=AllocMem(SECURITY_DESCRIPTOR_MIN_LENGTH);

  // Initialize the new security descriptor
  if InitializeSecurityDescriptor(sd, SECURITY_DESCRIPTOR_REVISION) then
  begin
     // Add a NULL descriptor ACL to the security descriptor
     if SetSecurityDescriptorDacl(sd, True, nil, False) then
     begin
        // Set up the security attributes structure
        SA.nLength:=SizeOf(TSecurityAttributes);
        SA.lpSecurityDescriptor:=sd;
        SA.bInheritHandle:=True;
     end
     else
        // Failed to init the sec descriptor
        RaiseWindowsError;
  end
  else
     // Failed to init the sec descriptor
     RaiseWindowsError;

end;

procedure FinalizeSecurity(var SA: TSecurityAttributes);
begin

  // Release memory that was assigned to security descriptor
  if Assigned(SA.lpSecurityDescriptor) then
  begin
     // Reource protection
     try
        // Free memory
        FreeMem(SA.lpSecurityDescriptor);
     finally
        // Clear pointer
        SA.lpSecurityDescriptor:=nil;
     end;
  end;

end;

//// Object instance handling //////////////////////////////////////////////////
function StdWndProc(Window: HWND; Message, WParam: Longint; LParam: Longint): Longint; stdcall; assembler;
asm
  xor   eax, eax
  push  eax
  push  LParam
  push  WParam
  push  Message
  mov   edx, esp
  mov   eax, [ecx].LongInt[4]
  call  [ecx].Pointer
  add   esp, 12
  pop   eax
end;

function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin

  // Calculate the jump offset
  result:=Longint(Dest) - (Longint(Src) + 5);

end;

function CalcJmpTarget(Src: Pointer; Offs: integer): Pointer;
begin

  // Calculate the jump target
  Integer(result):=Offs + (Longint(Src) + 5);

end;

function GetInstanceBlock(ObjectInstance: Pointer): PInstanceBlock;
var  lpInst:        PObjectInstance;
begin

  // Cast as object instance
  lpInst:=ObjectInstance;

  // Check instance
  if (lpInst = nil) then
     // Return nil
     result:=nil
  else
     // Get instance block
     Pointer(Result):=Pointer(LongInt(CalcJmpTarget(lpInst, lpInst^.Offset)) - SizeOf(Word) - SizeOf(PInstanceBlock));

end;

function MakeObjectInstance(Method: TWndMethod): Pointer;
var  lpBlock:       PInstanceBlock;
     lpInst:        PObjectInstance;
const
  BlockCode:        Array [1..2] of Byte =  (
                                               $59,  // POP ECX
                                               $E9   // JMP StdWndProc
                                            );
  PageSize          =  4096;
begin

  // Enter critical section
  EnterCriticalSection(InstCritSect);

  // Resource protection
  try
     // Check free list
     if (InstFreeList = nil) then
     begin
        // Allocate a new instance block
        lpBlock:=VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
        // Update the next pointer
        lpBlock^.Next:=InstBlockList;
        // Set block code
        Word(lpBlock^.Code):=Word(BlockCode);
        // Set wndproc pointer
        lpBlock^.WndProcPtr:=Pointer(CalcJmpOffset(@lpBlock^.Code[2], @StdWndProc));
        // Set block counter
        lpBlock^.Counter:=0;
        // Update all block instances
        lpInst:=@lpBlock^.Instances;
        repeat
           // Set call to near pointer offser
           lpInst^.Code:=$E8;
           // Calculate the jump offset
           lpInst^.Offset:=CalcJmpOffset(lpInst, @lpBlock^.Code);
           // Set next instance
           lpInst^.Next:=InstFreeList;
           // Update the instance list
           InstFreeList:=lpInst;
           // Push pointer forward
           Inc(LongInt(lpInst), SizeOf(TObjectInstance));
        until (Longint(lpInst)-Longint(lpBlock) >= SizeOf(TInstanceBlock));
        // Update the block list
        InstBlockList:=lpBlock;
     end;
     // Get instance from free list
     result:=InstFreeList;
     // Next instance in free list
     lpInst:=InstFreeList;
     InstFreeList:=lpInst^.Next;
     // Update the moethod pointer
     lpInst^.Method:=Method;
     // Increment the block counter
     Inc(GetInstanceBlock(lpInst)^.Counter);
  finally
     // Leave the critical section
     LeaveCriticalSection(InstCritSect);
  end;

end;

function FreeInstanceBlock(Block: Pointer): Boolean;
var  lpBlock:       PInstanceBlock;
     lpInst:        PObjectInstance;
     lpPrev:        PObjectInstance;
     lpNext:        PObjectInstance;
begin

  // Get the instance block
  lpBlock:=Block;

  // Check the block
  if (lpBlock = nil) or (lpBlock^.Counter > 0) then
     // Cant free instance block
     result:=False
  else
  begin
     // Get free list
     lpInst:=InstFreeList;
     // Set previous
     lpPrev:=nil;
     // While assigned
     while Assigned(lpInst) do
     begin
        // Get next instance
        lpNext:=lpInst^.Next;
        // Check instance block against passed block
        if (GetInstanceBlock(lpInst) = lpBlock) then
        begin
           // Check previous
           if Assigned(lpPrev) then lpPrev^.Next:=lpNext;
           // Check against list
           if (lpInst = InstFreeList) then InstFreeList:=lpNext;
        end;
        // Update previous
        lpPrev:=lpInst;
        // Next instance
        lpInst:=lpNext;
     end;
     // Free the block of memory
     VirtualFree(lpBlock, 0, MEM_RELEASE);
     // Success
     result:=True;
  end;

end;

procedure FreeInstanceBlocks;
var  lpPrev:        PInstanceBlock;
     lpNext:        PInstanceBlock;
     lpBlock:       PInstanceBlock;
begin

  // Set previous to nil
  lpPrev:=nil;

  // Get current block
  lpBlock:=InstBlockList;

  // While assigned
  while Assigned(lpBlock) do
  begin
     // Get next block
     lpNext:=lpBlock^.Next;
     // Attempt to free
     if FreeInstanceBlock(lpBlock) then
     begin
        // Relink blocks
        if Assigned(lpPrev) then lpPrev^.Next:=lpNext;
        // Reset list if needed
        if (lpBlock = InstBlockList) then InstBlockList:=lpNext;
     end
     else
        // Failed to free block
        lpBlock:=nil;
     // Update previous
     lpPrev:=lpBlock;
     // Next block
     lpBlock:=lpNext;
  end;

end;

procedure FreeObjectInstance(ObjectInstance: Pointer);
var  lpBlock:       PInstanceBlock;
begin

  // Check instance
  if Assigned(ObjectInstance) then
  begin
     // Enter critical section
     EnterCriticalSection(InstCritSect);
     // Resource protection
     try
        // Get instance block
        lpBlock:=GetInstanceBlock(ObjectInstance);
        // Check block
        if Assigned(lpBlock) then
        begin
           // Check block counter
           if ((lpBlock^.Counter > 0) and (lpBlock^.Counter <= Succ(INSTANCE_COUNT))) then
           begin
              // Set the next pointer
              PObjectInstance(ObjectInstance)^.Next:=InstFreeList;
              // Update free list
              InstFreeList:=ObjectInstance;
              // Decrement the counter
              Dec(lpBlock^.Counter);
              // If counter is at (or below) zero then free the instance blocks
              if (lpBlock^.Counter <= 0) then FreeInstanceBlocks;
           end;
        end;
     finally
        // Leave critical section
        LeaveCriticalSection(InstCritSect);
     end;
  end;

end;

function AllocateHWnd(Method: TWndMethod): HWND;
var  clsTemp:       TWndClass;
     bClassReg:     Boolean;
begin

  // Enter critical section
  EnterCriticalSection(InstCritSect);

  // Resource protection
  try
     // Set instance handle
     ObjWndClass.hInstance:=HInstance;
     // Attempt to get class info
     bClassReg:=GetClassInfo(HInstance, ObjWndClass.lpszClassName, clsTemp);
     // Ensure the class is registered and the window procedure is the default window proc
     if not(bClassReg) or not(clsTemp.lpfnWndProc = @DefWindowProc) then
     begin
        // Unregister if already registered
        if bClassReg then Windows.UnregisterClass(ObjWndClass.lpszClassName, HInstance);
        // Register
        Windows.RegisterClass(ObjWndClass);
     end;
     // Create the window
     result:=CreateWindowEx(0, ObjWndClass.lpszClassName, '', WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);
     // Set method pointer
     if Assigned(Method) then SetWindowLong(result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
  finally
     // Leave critical section
     LeaveCriticalSection(InstCritSect);
  end;

end;

procedure DeallocateHWnd(Wnd: HWND);
var  Instance:      Pointer;
begin

  // Enter critical section
  EnterCriticalSection(InstCritSect);

  // Resource protection
  try
     // Get the window procedure
     Instance:=Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
     // Resource protection
     try
        // Destroy the window
        DestroyWindow(Wnd);
     finally
        // If not the default window procedure then free the object instance
        if Assigned(Instance) and not(Instance = @DefWindowProc) then FreeObjectInstance(Instance);
     end;
  finally
     // Leave critical section
     LeaveCriticalSection(InstCritSect);
  end;

end;

procedure CreateMessageQueue;
var  lpMsg:         TMsg;
begin

  // Spin a message queue
  PeekMessage(lpMsg, 0, WM_USER, WM_USER, PM_NOREMOVE);

end;

procedure Register;
begin

  // Register the components under the Win32 tab
  RegisterComponents('Win32', [TPipeServer, TPipeClient, TPipeConsole]);

end;

initialization

  // Initialize the critical section for instance handling
  InitializeCriticalSection(InstCritSect);

  // If this is a console application then create a message queue
  if IsConsole then CreateMessageQueue;

finalization

  // Check sync manager
  if Assigned(SyncManager) then FreeAndNil(SyncManager);

  // Delete the critical section for instance handling
  DeleteCriticalSection(InstCritSect);

end.
